futhark 0.20.4 → 0.20.5

raw patch · 85 files changed

+6398/−4912 lines, 85 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• docs/error-index.rst +329/−2
• docs/index.rst +4/−4
• docs/language-reference.rst +89/−48
• docs/man/futhark-autotune.rst +7/−0
• docs/man/futhark-bench.rst +7/−0
• docs/man/futhark-test.rst +8/−0
• futhark.cabal +8/−2
• src/Futhark/Analysis/HORep/MapNest.hs +2/−4
• src/Futhark/Analysis/Interference.hs +1/−1
• src/Futhark/Analysis/Rephrase.hs +2/−2
• src/Futhark/CLI/Autotune.hs +12/−4
• src/Futhark/CLI/Bench.hs +10/−2
• src/Futhark/CLI/Dataset.hs +1/−0
• src/Futhark/CLI/Misc.hs +3/−3
• src/Futhark/CLI/Test.hs +9/−2
• src/Futhark/CodeGen/Backends/GenericC/CLI.hs +6/−0
• src/Futhark/CodeGen/ImpGen.hs +10/−9
• src/Futhark/CodeGen/ImpGen/GPU.hs +4/−2
• src/Futhark/CodeGen/ImpGen/GPU/SegScan/SinglePass.hs +2/−2
• src/Futhark/Construct.hs +3/−7
• src/Futhark/Doc/Generator.hs +17/−7
• src/Futhark/IR/GPU/Simplify.hs +2/−1
• src/Futhark/IR/GPUMem.hs +1/−1
• src/Futhark/IR/MCMem.hs +1/−1
• src/Futhark/IR/Mem.hs +1/−1
• src/Futhark/IR/Parse.hs +9/−5
• src/Futhark/IR/Pretty.hs +4/−2
• src/Futhark/IR/Prop/Names.hs +1/−1
• src/Futhark/IR/SOACS/Simplify.hs +106/−106
• src/Futhark/IR/SegOp.hs +10/−11
• src/Futhark/IR/SeqMem.hs +1/−1
• src/Futhark/IR/Syntax.hs +0/−35
• src/Futhark/IR/Syntax/Core.hs +41/−2
• src/Futhark/Internalise/Bindings.hs +35/−18
• src/Futhark/Internalise/Defunctionalise.hs +82/−46
• src/Futhark/Internalise/Defunctorise.hs +8/−9
• src/Futhark/Internalise/Exps.hs +73/−51
• src/Futhark/Internalise/FreeVars.hs +2/−2
• src/Futhark/Internalise/Lambdas.hs +5/−5
• src/Futhark/Internalise/LiftLambdas.hs +6/−5
• src/Futhark/Internalise/Monomorphise.hs +80/−51
• src/Futhark/Internalise/TypesValues.hs +34/−26
• src/Futhark/MonadFreshNames.hs +1/−1
• src/Futhark/Optimise/DoubleBuffer.hs +6/−11
• src/Futhark/Optimise/Fusion.hs +8/−8
• src/Futhark/Optimise/Fusion/Composing.hs +1/−1
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +1/−3
• src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +3/−0
• src/Futhark/Optimise/TileLoops.hs +2/−2
• src/Futhark/Pass/ExpandAllocations.hs +1/−1
• src/Futhark/Pass/ExplicitAllocations.hs +24/−28
• src/Futhark/Pass/ExtractKernels/Distribution.hs +4/−4
• src/Futhark/Pass/ExtractKernels/Interchange.hs +3/−3
• src/Futhark/Pass/ExtractKernels/StreamKernel.hs +2/−3
• src/Futhark/Pass/ExtractMulticore.hs +2/−2
• src/Futhark/Script.hs +9/−2
• src/Futhark/Test.hs +33/−455
• src/Futhark/Test/Spec.hs +463/−0
• src/Futhark/Transform/FirstOrderTransform.hs +1/−1
• src/Futhark/Transform/Rename.hs +16/−12
• src/Futhark/Transform/Substitute.hs +2/−1
• src/Futhark/TypeCheck.hs +1/−1
• src/Language/Futhark/Interpreter.hs +26/−32
• src/Language/Futhark/Parser/Lexer.x +4/−0
• src/Language/Futhark/Parser/Parser.y +38/−26
• src/Language/Futhark/Pretty.hs +18/−5
• src/Language/Futhark/Prop.hs +130/−118
• src/Language/Futhark/Query.hs +9/−17
• src/Language/Futhark/Semantic.hs +4/−2
• src/Language/Futhark/Syntax.hs +57/−14
• src/Language/Futhark/Traversals.hs +25/−9
• src/Language/Futhark/TypeChecker.hs +49/−47
• src/Language/Futhark/TypeChecker/Match.hs +1/−0
• src/Language/Futhark/TypeChecker/Modules.hs +61/−67
• src/Language/Futhark/TypeChecker/Monad.hs +48/−22
• src/Language/Futhark/TypeChecker/Terms.hs +1737/−3288
• src/Language/Futhark/TypeChecker/Terms/DoLoop.hs +380/−0
• src/Language/Futhark/TypeChecker/Terms/Monad.hs +1040/−0
• src/Language/Futhark/TypeChecker/Terms/Pat.hs +415/−0
• src/Language/Futhark/TypeChecker/Types.hs +308/−122
• src/Language/Futhark/TypeChecker/Unify.hs +104/−120
• unittests/Language/Futhark/SyntaxTests.hs +160/−2
• unittests/Language/Futhark/TypeChecker/TypesTests.hs +151/−0
• unittests/Language/Futhark/TypeCheckerTests.hs +11/−0
• unittests/futhark_tests.hs +3/−1

@@ -127,6 +127,122 @@    let main (xs: *[]i32) : (*[]i32, *[]i32) = (xs, copy xs) +.. _consuming-parameter:++"Consuming parameter passed non-unique argument"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Caused by programs like the following::++  let update (xs: *[]i32) = xs with [0] = 0++  let f (ys: []i32) = update ys++The update ``function`` *consumes* its ``xs`` argument to perform an+:ref:`in-place update <in-place-updates>`, as denoted by the asterisk+before the type.  However, the ``f`` function tries to pass an array+that it is not allowed to consume (no asterisk before the type).+++One solution is to change the type of ``f`` so that it also consumes+its input, which allows it to pass it on to ``update``::++  let f (ys: *[]i32) = update ys++Another solution to ``copy`` the array that we pass to ``update``::++  let f (ys: []i32) = update (copy ys)++.. _consuming-argument:++"Non-consuming higher-order parameter passed consuming argument."+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This error occurs when we have a higher-order function that expects a+function that does *not* consume its arguments, and we pass it one+that does::++  let apply 'a 'b (f: a -> b) (x: a) = f x++  let consume (xs: *[]i32) = xs with [0] = 0++  let f (arr: *[]i32) = apply consume arr++We can fix this by changing ``consume`` so that it does not have to+consume its argument, by adding a ``copy``::++  let consume (xs: []i32) = copy xs with [0] = 0++Or we can create a variant of ``apply`` that accepts a consuming+function::++  let apply 'a 'b (f: *a -> b) (x: *a) = f x++.. _alias-free-variable:++"Function result aliases the free variable *x*"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Caused by definitions such as the following::++  let x = [1,2,3]++  let f () = x++To simplify the tracking of aliases, the Futhark type system requires+that the result of a function may only alias the function parameters,+not any free variables.  Use ``copy`` to fix this::++  let f () = copy x++.. _inaccessible-size:++"Parameter *x* refers to size *y* which will not be accessible to the caller+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This happens when the size of an array parameter depends on a name+that cannot be expressed in the function type::++  let f (x: i64, y: i64) (A: [x]bool) = true++Intuitively, this function might have the following type::++  val f : (x: i64, y: i64) -> [x]bool -> bool++But this is not currently a valid Futhark type.  In a function type,+each parameter can be named *as a whole*, but it cannot be taken apart+in a pattern.  In this case, we could fix it by splitting the tuple+parameter into two separate parameters::++  let f (x: i64) (y: i64) (A: [x]bool) = true++This gives the following type::++  val f : (x: i64) -> (y: i64) -> [x]bool -> bool++Another workaround is to loosen the static safety, and use a size+coercion to give A its expected size::++  let f (x: i64, y: i64) (A_unsized: []bool) =+    let A = A_unsized :> [x]bool+    in true++This will produce a function with the following type::++  val f [d] : (i64, i64) -> [d]bool -> bool++This does however lose the constraint that the size of the array must+match one of the elements of the tuple, which means the program may+fail at run-time.++The error is not always due to an explicit type annotation.  It might+also be due to size inference::++  let f (x: i64, y: i64) (A: []bool) = zip A (iota x)++Here the type rules force ``A`` to have size ``x``, leading to a+problematic type.  It can be fixed using the techniques above.+ Size errors ----------- @@ -170,9 +286,85 @@ In many other cases, we can lift out the "size-producing" expressions into a separate ``let``-binding preceding the problematic expressions. -Other errors-------------+.. _unknowable-param-def: +"Unknowable size *x* in parameter of *y*"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This error occurs when you define a function that can never be+applied, as it requires an input of a specific size, and that size is+not known.  Somewhat contrived example::++  let f (x: bool) =+    let n = if x then 10 else 20+    in \(y: [n]bool) -> ...++The above constructs a function that accepts an array of size 10 or+20, based on the value of ``x`` argument.  But the type of ``f true``+by itself would be ``?[n].[n]bool -> bool``, where the ``n`` is+unknown.  There is no way to construct an array of the right size, so+the type checker rejects this program. (In a fully dependently typed+language, the type would have been ``[10]bool -> bool``, but Futhark+does not do any type-level computation.)++In most cases, this error means you have done something you didn't+actually mean to.  However, in the case that that the above really is+what you intend, the workaround is to make the function fully+polymorphic, and then perform a size coercion to the desired size+inside the function body itself::++  let f (x: bool) =+    let n = if x then 10 else 20+    in \(y_any: []bool) ->+         let y = y_any :> [n]bool+         in true++This requires a check at run-time, but it is the only way to+accomplish this in Futhark.++.. _existential-param-ret:++"Existential size would appear in function parameter of return type"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This occurs most commonly when we use function composition with one or+more functions that return an *existential size*.  Example::++  filter (>0) >-> length++The ``filter`` function has this type::++  val filter [n] 't : (t -> bool) -> [n]t -> ?[m].[m]t++That is, ``filter`` returns an array whose size is not known until the+function actually returns.  The ``length`` function has this type::++  val length [n] 't : [n]t -> i64++Whenever ``length`` occurs (as in the composition above), the type+checker must *instantiate* the ``[n]`` with the concrete symbolic size+of its input array.  But in the composition, that size does not+actually exist until ``filter`` has been run.  For that matter, the+type checker does not know what ``>->`` does, and for all it knows it+may actually apply ``filter`` many times to different arrays, yielding+different sizes.  This makes it impossible to uniquely instantiate the+type of ``length``, and therefore the program is rejected.++The common workaround is to use *pipelining* instead of composition+whenever we use functions with existential return types::++  xs |> filter (>0) |> length++This works because ``|>`` is left-associative, and hence the ``xs |>+filter (>0)`` part will be fully evaluated to a concrete array before+``length`` is reached.++We can of course also write it as ``length (filter (>0) xs)``, with no+use of either pipelining or composition.++Module errors+-------------+ .. _nested-entry:  "Entry points may not be declared inside modules."@@ -194,3 +386,138 @@   }    entry f = m.f++.. _module-is-parametric:++"Module *x* is a parametric module+----------------------------------++A parametric module is a module-level function::++  module PM (P: {val x : i64}) = {+    let y = x + 2+  }++If we directly try to access the component of ``PM``, as ``PM.y``, we+will get an error.  To use ``PM`` we must first apply it to a module+of the expected type::++  module M = PM { val x = 2 : i64 }++Now we can say ``M.y``.  See :ref:`module-system` for more.++Other errors+------------++.. _literal-out-of-bounds:++"Literal out of bounds"+~~~~~~~~~~~~~~~~~~~~~~~++This occurs for overloaded constants such as ``1234`` that are+inferred by context to have a type that is too narrow for their value.+Example::++  257 : u8++It is not an error to have a *non-overloaded* numeric constant whose+value is too large for its type.  The following is perfectly+cromulent::++  257u8++In such cases, the behaviour is overflow (so this is equivalent to+``1u8``).++.. _ambiguous-type:++"Type is ambiguous"+~~~~~~~~~~~~~~~~~~~++There are various cases where the type checker is unable to infer the+full type of something.  For example::++  let f r = r.x++We know that ``r`` must be a record with a field called ``x``, but+maybe the record could also have other fields as well.  Instead of+assuming a perhaps too narrow type, the type checker signals an error.+The solution is always to add a type annotation in one or more places+to disambiguate the type::++  let f (r: {x:bool, y:i32}) = r.x++Usually the best spot to add such an annotation is on a function+parameter, as above.  But for ambiguous sum types, we often have to+put it on the return type.  Consider::++  let f (x: bool) = #some x++The type of this function is ambiguous, because the type checker must+know what other possible contructors (apart from ``#some``) are+possible.  We fix it with a type annotation on the return type::++  let f (x: bool) : (#some bool | #none) = #just x++See :ref:`typeabbrevs` for how to avoid typing long types in several+places.++.. _may-not-be-redefined:++"The *x* operator may not be redefined"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The ``&&`` and ``||`` operators have magical short-circuiting+behaviour, and therefore may not be redefined.  There is no way to+define your own short-circuiting operators.++.. _unmatched-cases:++"Unmatched cases in match expression"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Futhark requires ``match`` expressions to be *exhaustive* - that is,+cover all possible forms of the value being pattern-matches.+Example::++  let f (x: i32) =+    match x case 0 -> false+            case 1 -> true++Usually this is an actual bug, and you fix it by adding the missing+cases.  But sometimes you *know* that the missing cases will never+actually occur at run-time.  To satisfy the type checker, you can turn+the final case into a wildcard that matches anything::++  let f (x: i32) =+    match x case 0 -> false+            case _ -> true++Alternatively, you can add a wildcard case that explicitly asserts+that it should never happen::++  let f (x: i32) =+    match x case 0 -> false+            case 1 -> true+            case _ -> assert false false++:ref:`See here <assert>` for details on how to use ``assert``.++.. _record-type-not-known:++"Full type of *x* is not known at this point"+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When performing a :ref:`record update <record_update>`, the type of the+field we are updating must be known.  This restriction is based on a+limitation in the type type checker, so the notion of "known" is a bit+subtle::++  let f r : {x:i32} = r with x = 0++Even though the return type annotation disambiguates the type, this+program still fails to type check.  This is because the return type is+not consulted until *after* the body of the function has been checked.+The solution is to put a type annotation on the parameter instead::++  let f (r : {x:i32}) = r with x = 0

@@ -48,17 +48,17 @@    man/futhark-autotune.rst    man/futhark-bench.rst    man/futhark-c.rst-   man/futhark-multicore.rst    man/futhark-cuda.rst    man/futhark-dataset.rst    man/futhark-doc.rst+   man/futhark-literate.rst+   man/futhark-multicore.rst    man/futhark-opencl.rst    man/futhark-pkg.rst    man/futhark-pyopencl.rst    man/futhark-python.rst-   man/futhark-wasm.rst-   man/futhark-wasm-multicore.rst    man/futhark-repl.rst    man/futhark-run.rst-   man/futhark-literate.rst    man/futhark-test.rst+   man/futhark-wasm.rst+   man/futhark-wasm-multicore.rst

@@ -104,6 +104,7 @@        : | `sum_type`        : | `function_type`        : | `type_application`+       : | `existential_size`  Compound types can be constructed based on the primitive types.  The Futhark type system is entirely structural, and type abbreviations are@@ -134,15 +135,19 @@ array type is written as ``[d]t``, where ``t`` is the element type of the array, and ``d`` is an integer or variable indicating the size. We can often elide ``d`` and write just ``[]`` (an *anonymous size*),-in which case the size will be inferred.  As an example, an array of-three integers could be written as ``[1,2,3]``, and has type-``[3]i32``.  An empty array is written as ``[]``, and its type is-inferred from its use.  When writing Futhark values for such uses as-``futhark test`` (but not when writing programs), empty arrays are-written ``empty([0]t)`` for an empty array of type ``[0]t``.  When-using ``empty``, all dimensions must be given a size, and at least one-must be zero, e.g. ``empty([2][0]i32)``.+in which case the size will be inferred.  An anonymous size is a+syntactic shorthand, and is always replaced by an actual size by the+type checker (either via inference or by inventing a new name,+depending on context). +As an example, an array of three integers could be written as+``[1,2,3]``, and has type ``[3]i32``.  An empty array is written as+``[]``, and its type is inferred from its use.  When writing Futhark+values for such uses as ``futhark test`` (but not when writing+programs), empty arrays are written ``empty([0]t)`` for an empty array+of type ``[0]t``.  When using ``empty``, all dimensions must be given+a size, and at least one must be zero, e.g. ``empty([2][0]i32)``.+ Multi-dimensional arrays are supported in Futhark, but they must be *regular*, meaning that all inner arrays must have the same shape. For example, ``[[1,2], [3,4], [5,6]]`` is a valid array of type@@ -200,6 +205,13 @@ Futhark, but character literals are interpreted as integers of the corresponding Unicode code point. +.. productionlist::+   existential_size: "?" ("[" `id` "]")+ "." `type`++An existential size quantifier brings an unknown size into scope+within a type.  This can be used to encode constraints for statically+unknowable array sizes.+ Declarations ------------ @@ -346,6 +358,8 @@ (see `Size types`_), new existential sizes will be constructed for them. +.. _typeabbrevs:+ Type Abbreviations ~~~~~~~~~~~~~~~~~~ @@ -359,12 +373,12 @@ abbreviations do not create distinct types: the types ``t1`` and ``t2`` are entirely interchangeable. -If the right-hand side of a type contains anonymous sizes, it must be-declared "size-lifted" with ``type~``.  If it (potentially) contains a-function, it must be declared "fully lifted" with ``type^``.  A lifted-type can also contain anonymous sizes.  Lifted types cannot be put in-arrays.  Fully lifted types cannot be returned from conditional or-loop expressions.+If the right-hand side of a type contains existential sizes, it must+be declared "size-lifted" with ``type~``.  If it (potentially)+contains a function, it must be declared "fully lifted" with+``type^``.  A lifted type can also contain existential sizes.  Lifted+types cannot be put in arrays.  Fully lifted types cannot be returned+from conditional or loop expressions.  A type abbreviation can have zero or more parameters.  A type parameter enclosed with square brackets is a *size parameter*, and@@ -443,7 +457,7 @@       : | "let" `id` `type_param`* `pat`+ [":" `type`] "=" `exp` "in" `exp`       : | "(" "\" `pat`+ [":" `type`] "->" `exp` ")"       : | "loop" `pat` [("=" `exp`)] `loopform` "do" `exp`-      : | "#[" attr "]" `exp`+      : | "#[" `attr` "]" `exp`       : | "unsafe" `exp`       : | "assert" `atom` `atom`       : | `exp` "with" "[" `index` ("," `index`)* "]" "=" `exp`@@ -462,6 +476,7 @@       : | "{" `fieldid` ["=" `pat`] ("," `fieldid` ["=" `pat`])* "}"       : | `constructor` `pat`*       : | `pat` ":" `type`+      : | "#[" `attr` "]" `pat`    pat_literal: [ "-" ] `intnumber`               | [ "-" ] `floatnumber`               | `charlit`@@ -838,6 +853,8 @@  This construct is deprecated.  Use the ``#[unsafe]`` attribute instead. +.. _assert:+ ``assert cond e`` ................. @@ -852,6 +869,8 @@ Return ``a``, but with the element at position ``i`` changed to contain the result of evaluating ``e``.  Consumes ``a``. +.. _record_update:+ ``r with f = e`` ................. @@ -1040,10 +1059,15 @@ We use a *size parameter*, ``[n]``, to explicitly quantify sizes.  The ``[n]`` parameter is not explicitly passed when calling ``f``. Rather, its value is implicitly deduced from the arguments passed for-the value parameters.  An array can contain *anonymous dimensions*,-e.g. ``[]i32``, for which the type checker will invent fresh size-parameters, which ensures that all arrays have a (symbolic) size.+the value parameters.  An array type can contain *anonymous+dimensions*, e.g. ``[]i32``, for which the type checker will invent+fresh size parameters, which ensures that all arrays have a (symbolic)+size.  On the right-hand side of a function arrow ("return types"),+this results in an *existential size* that is not known until the+function is fully applied, e.g:: +  val filter [n] 'a : (p: a -> bool) -> (as: [n]a) -> ?[k].[k]a+ A size annotation can also be an integer constant (with no suffix). Size parameters can be used as ordinary variables within the scope of the parameters.  The type checker verifies that the program obeys any@@ -1071,14 +1095,14 @@   val concat [n] [m] 't : [n]t -> [m]t -> [n+m]t  But this is not presently allowed.  Instead, the return type contains-an anonymous size::+an existential size:: -  val concat [n] [m] 't : [n]t -> [m]t -> []t+  val concat [n] [m] 't : [n]t -> [m]t -> ?[k].[k]t  When an application ``concat xs ys`` is found, the result will be of-type ``[k]t``, where ``k`` is a fresh *unknown* size variable that is-considered distinct from every other size in the program.  It is often-necessary to perform a size coercion (see `Size coercion`_) to+type ``[k']t``, where ``k'`` is a fresh *unknown* size variable that+is considered distinct from every other size in the program.  It is+often necessary to perform a size coercion (see `Size coercion`_) to convert an unknown size to a known size.  Generally, unknown sizes are constructed whenever the true size cannot@@ -1127,19 +1151,19 @@ Exceptions exist for :ref:`general ranges <range>` and :ref:`"upto" ranges <range_upto>`. -Anonymous size in function return type-......................................+Existential size in function return type+........................................ -Whenever the result of a function application would have an anonymous+Whenever the result of a function application has an existential size, that size is replaced with a fresh unknown size variable.  For example, ``filter`` has the following type:: -  val filter [n] 'a : (p: a -> bool) -> (as: [n]a) -> []a+  val filter [n] 'a : (p: a -> bool) -> (as: [n]a) -> ?[k].[k]a -Naively, an application ``filter f xs`` seems like it would have type-``[]a``, but a fresh unknown size ``k`` will be created and the actual-type will be ``[k]a``.+For an application ``filter f xs``, the type checker invents a fresh+unknown size ``k'``, and the actual type for this specific application+will be ``[k']a``.  Branches of ``if`` return arrays of different sizes ...................................................@@ -1258,8 +1282,8 @@ When matching a module with a module type (see :ref:`module-system`), a non-lifted abstract type (i.e. one that is declared with ``type`` rather than ``type^``) may not be implemented by a type abbreviation-that contains any anonymous sizes.  This is to ensure that if we have-the following::+that contains any existential sizes.  This is to ensure that if we+have the following::    module m : { type t } = ... @@ -1271,20 +1295,20 @@  When a higher-order function takes a functional argument whose return type is a non-lifted type parameter, any instantiation of that type-parameter must have a non-anonymous size.  If the return type is a-lifted type parameter, then the instantiation may contain anonymous+parameter must have a non-existential size.  If the return type is a+lifted type parameter, then the instantiation may contain existential sizes.  This is why the type of ``map`` guarantees regular arrays::    val map [n] 'a 'b : (a -> b) -> [n]a -> [n]b  The type parameter ``b`` can only be replaced with a type that has-non-anonymous sizes, which means they must be the same for every+non-existential sizes, which means they must be the same for every application of the function.  In contrast, this is the type of the pipeline operator::    val (|>) '^a -> '^b : a -> (a -> b) -> b -The provided function can return something with an anonymous size+The provided function can return something with an existential size (such as ``filter``).  A function whose return type has an unknown size@@ -1292,7 +1316,7 @@  If a function (named or anonymous) is inferred to have a return type that contains an unknown size variable created *within* the function-body, that size variable will be replaced with an anonymous size.  In+body, that size variable will be replaced with an existential size.  In most cases this is not important, but it means that an expression like the following is ill-typed:: @@ -1300,7 +1324,7 @@  This is because the ``(length xs)`` expression gives rise to some fresh size ``k``.  The lambda is then assigned the type ``[n]t ->-[k]i32``, which is immediately turned into ``[n]t -> []i32`` because+[k]i32``, which is immediately turned into ``[n]t -> ?[k].[k]i32`` because ``k`` was generated inside its body.  A function of this type cannot be passed to ``map``, as explained before.  The solution is to bind ``length`` to a name *before* the lambda.@@ -1329,6 +1353,15 @@    val g : () -> [][]i32 +As this above would be elaborated as follows::++  val g : () -> ?[n][m].[n][m]i32++We can of course explicitly write that the function returns a square+array of existential size::++  val g : () -> ?[n].[n]i32+ .. _in-place-updates:  In-place Updates@@ -1646,18 +1679,19 @@  .. productionlist::    attr:   `id`+       :   `decimal`        : | `id` "(" [`attr` ("," `attr`)*] ")" -An expression, declaration, or module type spec can be prefixed with-an attribute, written as ``#[attr]``.  This may affect how it is-treated by the compiler or other tools.  In no case will attributes-affect or change the *semantics* of a program, but it may affect how-well it compiles and runs (or in some cases, whether it compiles or-runs at all).  Unknown attributes are silently ignored.  Most have no-effect in the interpreter.  An attribute can be either an *atom*,-written as just an identifier, or *compound*, consisting of an-identifier and a comma-separated sequence of attributes.  The latter-is used for grouping and encoding of more complex information.+An expression, declaration, pattern, or module type spec can be+prefixed with an attribute, written as ``#[attr]``.  This may affect+how it is treated by the compiler or other tools.  In no case will+attributes affect or change the *semantics* of a program, but it may+affect how well it compiles and runs (or in some cases, whether it+compiles or runs at all).  Unknown attributes are silently ignored.+Most have no effect in the interpreter.  An attribute can be either an+*atom*, written as an identifier or number, or *compound*, consisting+of an identifier and a comma-separated sequence of attributes.  The+latter is used for grouping and encoding of more complex information.  Expression attributes ~~~~~~~~~~~~~~~~~~~~~@@ -1788,6 +1822,13 @@ ..........  Always inline calls to this function.++Pattern attributes+~~~~~~~~~~~~~~~~~~++No pattern attributes are currently supported by the compiler itself,+although they are syntactically permitted and may be used by other+tools.  Spec attributes ~~~~~~~~~~~~~~~

@@ -53,6 +53,13 @@   Print verbose information about what the tuner is doing.  Pass   multiple times to increase the amount of information printed. +--spec-file=FILE++  Ignore the test specification in the program file(s), and instead+  load them from this other file.  These external test specifications+  use the same syntax as normal, but *without* line comment prefixes A+  ``==`` is still expected.+ --tuning=EXTENSION    Change the extension used for tuning files (``.tuning`` by default).

@@ -99,6 +99,13 @@   Do not run the compiler, and instead assume that each benchmark   program has already been compiled.  Use with caution. +--spec-file=FILE++  Ignore the test specification in the program file(s), and instead+  load them from this other file.  These external test specifications+  use the same syntax as normal, but *without* line comment prefixes.+  A ``==`` is still expected.+ --timeout=seconds    If the runtime for a dataset exceeds this integral number of

@@ -193,6 +193,14 @@   ``foo.fut`` will be passed the tuning file ``foo.fut.tuning`` if it   exists. +ENVIRONMENT VARIABLES+=====================++``TMPDIR``++  Directory used for temporary files such as gunzipped datasets and+  log files.+ EXAMPLES ======== 

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.20.4+version:        0.20.5 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -260,6 +260,7 @@       Futhark.Pkg.Types       Futhark.Script       Futhark.Test+      Futhark.Test.Spec       Futhark.Test.Values       Futhark.Tools       Futhark.Transform.CopyPropagate@@ -292,6 +293,9 @@       Language.Futhark.TypeChecker.Modules       Language.Futhark.TypeChecker.Monad       Language.Futhark.TypeChecker.Terms+      Language.Futhark.TypeChecker.Terms.DoLoop+      Language.Futhark.TypeChecker.Terms.Monad+      Language.Futhark.TypeChecker.Terms.Pat       Language.Futhark.TypeChecker.Types       Language.Futhark.TypeChecker.Unify       Language.Futhark.Warnings@@ -308,7 +312,7 @@       alex:alex     , happy:happy   build-depends:-      aeson >=1.0.0.0+      aeson < 2     , ansi-terminal >=0.6.3.1     , array >=0.4     , base >=4.13 && <5@@ -385,6 +389,8 @@       Futhark.IR.PrimitiveTests       Language.Futhark.CoreTests       Language.Futhark.SyntaxTests+      Language.Futhark.TypeCheckerTests+      Language.Futhark.TypeChecker.TypesTests       Futhark.Optimise.MemoryBlockMerging.GreedyColoringTests       Paths_futhark   hs-source-dirs:

@@ -131,9 +131,7 @@                   substituteNames subst $ lambdaBody lam,                 lambdaParams =                   lambdaParams lam-                    ++ [ Param name t-                         | Ident name t <- newParams-                       ]+                    ++ [Param mempty name t | Ident name t <- newParams]               }       return $ Just $ MapNest w lam' [] inps'   where@@ -152,7 +150,7 @@ toSOAC (MapNest w lam [] inps) =   return $ SOAC.Screma w (Futhark.mapSOAC lam) inps toSOAC (MapNest w lam (Nesting npnames nres nrettype nw : ns) inps) = do-  let nparams = zipWith Param npnames $ map SOAC.inputRowType inps+  let nparams = zipWith (Param mempty) npnames $ map SOAC.inputRowType inps   body <- runBodyBuilder $     localScope (scopeOfLParams nparams) $ do       letBindNames nres =<< SOAC.toExp

@@ -105,7 +105,7 @@   where     mems = mapMaybe isMemArg merge     inner_mems = namesToList lastused <> namesToList inuse-    isMemArg (Param _ MemMem {}, Var v) = Just v+    isMemArg (Param _ _ MemMem {}, Var v) = Just v     isMemArg _ = Nothing  analyseExp ::

@@ -75,8 +75,8 @@  -- | Rephrase a parameter. rephraseParam :: Monad m => (from -> m to) -> Param from -> m (Param to)-rephraseParam rephraser (Param name from) =-  Param name <$> rephraser from+rephraseParam rephraser (Param attrs name from) =+  Param attrs name <$> rephraser from  -- | Rephrase a body. rephraseBody :: Monad m => Rephraser m from to -> Body from -> m (Body to)

@@ -32,12 +32,13 @@     optExtraOptions :: [String],     optVerbose :: Int,     optTimeout :: Int,-    optDefaultThreshold :: Int+    optDefaultThreshold :: Int,+    optTestSpec :: Maybe FilePath   }  initialAutotuneOptions :: AutotuneOptions initialAutotuneOptions =-  AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0 60 thresholdMax+  AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0 60 thresholdMax Nothing  compileOptions :: AutotuneOptions -> IO CompileOptions compileOptions opts = do@@ -101,7 +102,9 @@  prepare :: AutotuneOptions -> FutharkExe -> FilePath -> IO [(DatasetName, RunDataset, T.Text)] prepare opts futhark prog = do-  spec <- testSpecFromFileOrDie prog+  spec <-+    maybe (testSpecFromProgramOrDie prog) testSpecFromFileOrDie $+      optTestSpec opts   copts <- compileOptions opts    truns <-@@ -476,7 +479,12 @@       "v"       ["verbose"]       (NoArg $ Right $ \config -> config {optVerbose = optVerbose config + 1})-      "Enable logging.  Pass multiple times for more."+      "Enable logging.  Pass multiple times for more.",+    Option+      []+      ["spec-file"]+      (ReqArg (\s -> Right $ \config -> config {optTestSpec = Just s}) "FILE")+      "Use test specification from this file."   ]  -- | Run @futhark autotune@

@@ -48,7 +48,8 @@     optEntryPoint :: Maybe String,     optTuning :: Maybe String,     optConcurrency :: Maybe Int,-    optVerbose :: Int+    optVerbose :: Int,+    optTestSpec :: Maybe FilePath   }  initialBenchOptions :: BenchOptions@@ -69,6 +70,7 @@     (Just "tuning")     Nothing     0+    Nothing  runBenchmarks :: BenchOptions -> [FilePath] -> IO () runBenchmarks opts paths = do@@ -132,7 +134,8 @@   BenchOptions ->   (FilePath, ProgramTest) ->   IO (Either SkipReason (FilePath, [InputOutputs]))-compileBenchmark opts (program, spec) =+compileBenchmark opts (program, program_spec) = do+  spec <- maybe (pure program_spec) testSpecFromFileOrDie $ optTestSpec opts   case testAction spec of     RunCases cases _ _       | "nobench" `notElem` testTags spec,@@ -496,6 +499,11 @@           "NUM"       )       "Number of benchmarks to prepare (not run) concurrently.",+    Option+      []+      ["spec-file"]+      (ReqArg (\s -> Right $ \config -> config {optTestSpec = Just s}) "FILE")+      "Use test specification from this file.",     Option       "v"       ["verbose"]

@@ -193,6 +193,7 @@ toValueType TEApply {} = Left "Cannot handle type applications yet." toValueType TEArrow {} = Left "Cannot generate functions." toValueType TESum {} = Left "Cannot handle sumtypes yet."+toValueType TEDim {} = Left "Cannot handle existential sizes." toValueType (TEUnique t _) = toValueType t toValueType (TEArray t d _) = do   d' <- constantDim d

@@ -17,7 +17,7 @@ import Futhark.Test import Futhark.Util (hashText) import Futhark.Util.Options-import Futhark.Util.Pretty (prettyText)+import Futhark.Util.Pretty (prettyTextOneLine) import System.Environment (getExecutablePath) import System.Exit import System.FilePath@@ -44,7 +44,7 @@       prog <- filter (not . isBuiltin . fst) <$> readUntypedProgramOrDie file       -- The 'map snd' is an attempt to get rid of the file names so       -- they won't affect the hashing.-      liftIO $ T.putStrLn $ hashText $ prettyText $ map snd prog+      liftIO $ T.putStrLn $ hashText $ prettyTextOneLine $ map snd prog     _ -> Nothing  -- | @futhark dataget@@@ -57,7 +57,7 @@     dataget prog dataset = do       let dir = takeDirectory prog -      runs <- testSpecRuns <$> testSpecFromFileOrDie prog+      runs <- testSpecRuns <$> testSpecFromProgramOrDie prog        let exact = filter ((dataset ==) . runDescription) runs           infixes = filter ((dataset `isInfixOf`) . runDescription) runs

@@ -152,17 +152,24 @@     actual <- optimisedProgramMetrics programs pipeline program     accErrors_ $ map (ok actual) $ M.toList expected   where+    maybePipeline :: StructurePipeline -> T.Text+    maybePipeline SOACSPipeline = "(soacs) "+    maybePipeline KernelsPipeline = "(kernels) "+    maybePipeline SequentialCpuPipeline = "(seq-mem) "+    maybePipeline GpuPipeline = "(gpu-mem) "+    maybePipeline NoPipeline = ""+     ok (AstMetrics metrics) (name, expected_occurences) =       case M.lookup name metrics of         Nothing           | expected_occurences > 0 ->             throwError $-              name <> " should have occurred " <> T.pack (show expected_occurences)+              name <> maybePipeline pipeline <> " should have occurred " <> T.pack (show expected_occurences)                 <> " times, but did not occur at all in optimised program."         Just actual_occurences           | expected_occurences /= actual_occurences ->             throwError $-              name <> " should have occurred " <> T.pack (show expected_occurences)+              name <> maybePipeline pipeline <> " should have occurred " <> T.pack (show expected_occurences)                 <> " times, but occurred "                 <> T.pack (show actual_occurences)                 <> " times."

@@ -404,6 +404,7 @@ $esc:("#include <getopt.h>") $esc:("#include <ctype.h>") $esc:("#include <inttypes.h>")+$esc:("#include <unistd.h>")  $esc:(T.unpack valuesH) @@ -471,6 +472,11 @@         fprintf(stderr, "%s\n", entry_points[i].name);       }       return 1;+    }++    if (isatty(fileno(stdin))) {+      fprintf(stderr, "Reading input from TTY.\n");+      fprintf(stderr, "Send EOF (CTRL-d) after typing all input values.\n");     }      entry_point_fun(ctx);

@@ -896,11 +896,13 @@   copy (elemType (patElemType pe)) (flatSliceMemLoc pe_loc slice') v_loc   where     slice' = fmap toInt64Exp slice-defCompileBasicOp (Pat [pe]) (Replicate (Shape ds) se) = do-  ds' <- mapM toExp ds-  is <- replicateM (length ds) (newVName "i")-  copy_elem <- collect $ copyDWIM (patElemName pe) (map (DimFix . Imp.vi64) is) se []-  emit $ foldl (.) id (zipWith Imp.For is ds') copy_elem+defCompileBasicOp (Pat [pe]) (Replicate (Shape ds) se)+  | Acc {} <- patElemType pe = pure ()+  | otherwise = do+    ds' <- mapM toExp ds+    is <- replicateM (length ds) (newVName "i")+    copy_elem <- collect $ copyDWIM (patElemName pe) (map (DimFix . Imp.vi64) is) se []+    emit $ foldl (.) id (zipWith Imp.For is ds') copy_elem defCompileBasicOp _ Scratch {} =   return () defCompileBasicOp (Pat [pe]) (Iota n e s it) = do@@ -909,10 +911,9 @@   sFor "i" (toInt64Exp n) $ \i -> do     let i' = sExt it $ untyped i     x <--      dPrimV "x" $-        TPrimExp $-          BinOpExp (Add it OverflowUndef) e' $-            BinOpExp (Mul it OverflowUndef) i' s'+      dPrimV "x" . TPrimExp $+        BinOpExp (Add it OverflowUndef) e' $+          BinOpExp (Mul it OverflowUndef) i' s'     copyDWIM (patElemName pe) [DimFix i] (Var (tvVar x)) [] defCompileBasicOp (Pat [pe]) (Copy src) =   copyDWIM (patElemName pe) [] (Var src) []

@@ -242,8 +242,10 @@   s' <- toExp s    sIota (patElemName pe) (toInt64Exp n) x' s' et-expCompiler (Pat [pe]) (BasicOp (Replicate _ se)) =-  sReplicate (patElemName pe) se+expCompiler (Pat [pe]) (BasicOp (Replicate _ se))+  | Acc {} <- patElemType pe = pure ()+  | otherwise =+    sReplicate (patElemName pe) se -- Allocation in the "local" space is just a placeholder. expCompiler _ (Op (Alloc _ (Space "local"))) =   return ()

@@ -109,8 +109,8 @@ inBlockScanLookback constants arrs_full_size flag_arr arrs scan_lam = everythingVolatile $ do   flg_x <- dPrim "flg_x" p_int8   flg_y <- dPrim "flg_y" p_int8-  let flg_param_x = Param (tvVar flg_x) (MemPrim p_int8)-      flg_param_y = Param (tvVar flg_y) (MemPrim p_int8)+  let flg_param_x = Param mempty (tvVar flg_x) (MemPrim p_int8)+      flg_param_y = Param mempty (tvVar flg_y) (MemPrim p_int8)       flg_y_exp = tvExp flg_y       statusP = (2 :: Imp.TExp Int8)       statusX = (0 :: Imp.TExp Int8)

@@ -111,7 +111,6 @@ import Control.Monad.State import Data.List (sortOn) import qualified Data.Map.Strict as M-import qualified Data.Set as S import Futhark.Builder import Futhark.IR import Futhark.Util (maybeNth)@@ -157,8 +156,6 @@   m [SubExp] letSubExps desc = mapM $ letSubExp desc --- | Only returns those pattern names that are not used in the pattern--- itself (the "non-existential" part, you could say). letTupExp ::   (MonadBuilder m) =>   String ->@@ -170,8 +167,7 @@   e_t <- expExtType e   names <- replicateM (length e_t) $ newVName name   letBindNames names e-  let ctx = shapeContext e_t-  pure $ map fst $ filter ((`S.notMember` ctx) . snd) $ zip names [0 ..]+  pure names  letTupExp' ::   (MonadBuilder m) =>@@ -442,8 +438,8 @@   return     Lambda       { lambdaParams =-          [ Param x (Prim arg_t),-            Param y (Prim arg_t)+          [ Param mempty x (Prim arg_t),+            Param mempty y (Prim arg_t)           ],         lambdaReturnType = [Prim ret_t],         lambdaBody = body

@@ -402,7 +402,7 @@         noLink $           map typeParamName tparams             ++ map identName (S.toList $ mconcat $ map patIdents params)-  rettype' <- noLink' $ maybe (typeHtml rettype) typeExpHtml retdecl+  rettype' <- noLink' $ maybe (retTypeHtml rettype) typeExpHtml retdecl   params' <- noLink' $ mapM patternHtml params   return     ( keyword "val " <> (H.span ! A.class_ "decl_name") name,@@ -438,8 +438,8 @@   fullRow <$> typeBindHtml name' tb  typeBindHtml :: Html -> TypeBind -> DocM Html-typeBindHtml name' (TypeBind _ l tparams t _ _) = do-  t' <- noLink (map typeParamName tparams) $ typeDeclHtml t+typeBindHtml name' (TypeBind _ l tparams t _ _ _) = do+  t' <- noLink (map typeParamName tparams) $ typeExpHtml t   return $ typeAbbrevHtml l name' tparams <> " = " <> t'  renderEnv :: Env -> DocM Html@@ -463,7 +463,7 @@  renderTypeBind :: (VName, TypeBinding) -> DocM Html renderTypeBind (name, TypeAbbr l tps tp) = do-  tp' <- typeHtml tp+  tp' <- retTypeHtml tp   return $ H.div $ typeAbbrevHtml l (vnameHtml name) tps <> " = " <> tp'  synopsisValBindBind :: (VName, BoundV) -> DocM Html@@ -498,7 +498,7 @@     return $ prettyU u <> et' <> mconcat (map (" " <>) targs')   Scalar (Arrow _ pname t1 t2) -> do     t1' <- typeHtml t1-    t2' <- typeHtml t2+    t2' <- retTypeHtml t2     return $ case pname of       Named v ->         parens (vnameHtml v <> ": " <> t1') <> " -> " <> t2'@@ -509,6 +509,12 @@       ppClause (n, ts) = joinBy " " . (ppConstr n :) <$> mapM typeHtml ts       ppConstr name = "#" <> toHtml (nameToString name) +retTypeHtml :: StructRetType -> DocM Html+retTypeHtml (RetType [] t) = typeHtml t+retTypeHtml (RetType dims t) = do+  t' <- typeHtml t+  pure $ "?" <> mconcat (map (brackets . vnameHtml) dims) <> "." <> t'+ prettyShapeDecl :: ShapeDecl (DimDecl VName) -> DocM Html prettyShapeDecl (ShapeDecl ds) =   mconcat <$> mapM (fmap brackets . dimDeclHtml) ds@@ -634,6 +640,9 @@     where       ppClause (n, ts) = joinBy " " . (ppConstr n :) <$> mapM typeExpHtml ts       ppConstr name = "#" <> toHtml (nameToString name)+  TEDim dims t _ -> do+    t' <- typeExpHtml t+    pure $ "?" <> mconcat (map (brackets . renderName . baseName) dims) <> "." <> t'  qualNameHtml :: QualName VName -> DocM Html qualNameHtml (QualName names vname@(VName name tag)) =@@ -679,9 +688,9 @@   concat (replicate (length (splitPath src) - 1) "../") ++ dest  dimDeclHtml :: DimDecl VName -> DocM Html-dimDeclHtml (AnyDim _) = return mempty dimDeclHtml (NamedDim v) = qualNameHtml v dimDeclHtml (ConstDim n) = return $ toHtml (show n)+dimDeclHtml AnyDim {} = pure mempty  dimExpHtml :: DimExp VName -> DocM Html dimExpHtml DimExpAny = return mempty@@ -827,7 +836,8 @@ valBindWhat :: ValBind -> IndexWhat valBindWhat vb   | null (valBindParams vb),-    orderZero (fst $ unInfo $ valBindRetType vb) =+    RetType _ t <- fst $ unInfo $ valBindRetType vb,+    orderZero t =     IndexValue   | otherwise =     IxFun

@@ -95,7 +95,8 @@       [ RuleOp redomapIotaToLoop,         RuleOp SOAC.simplifyKnownIterationSOAC,         RuleOp SOAC.removeReplicateMapping,-        RuleOp SOAC.liftIdentityMapping+        RuleOp SOAC.liftIdentityMapping,+        RuleOp SOAC.simplifyMapIota       ]       [ RuleBasicOp removeUnnecessaryCopy       ]

@@ -66,7 +66,7 @@   checkLParamDec = checkMemInfo   checkLetBoundDec = checkMemInfo   checkRetType = mapM_ $ TC.checkExtType . declExtTypeOf-  primFParam name t = return $ Param name (MemPrim t)+  primFParam name t = return $ Param mempty name (MemPrim t)   matchPat = matchPatToExp   matchReturnType = matchFunctionReturnType   matchBranchType = matchBranchReturnType

@@ -63,7 +63,7 @@   checkLParamDec = checkMemInfo   checkLetBoundDec = checkMemInfo   checkRetType = mapM_ (TC.checkExtType . declExtTypeOf)-  primFParam name t = return $ Param name (MemPrim t)+  primFParam name t = return $ Param mempty name (MemPrim t)   matchPat = matchPatToExp   matchReturnType = matchFunctionReturnType   matchBranchType = matchBranchReturnType

@@ -607,7 +607,7 @@       MemAcc acc ispace ts u     toRet (MemArray pt shape u (ArrayIn mem ixfun))       | Just i <- mem `elemIndex` param_names,-        Param _ (MemMem space) : _ <- drop i params =+        Param _ _ (MemMem space) : _ <- drop i params =         MemArray pt shape' u $ ReturnsNewBlock space i ixfun'       | otherwise =         MemArray pt shape' u $ ReturnsInBlock mem ixfun'

@@ -322,11 +322,15 @@     ]  pAttr :: Parser Attr-pAttr = do-  v <- pName+pAttr =   choice-    [ AttrComp v <$> parens (pAttr `sepBy` pComma),-      pure $ AttrAtom v+    [ AttrInt . toInteger <$> pInt,+      do+        v <- pName+        choice+          [ AttrComp v <$> parens (pAttr `sepBy` pComma),+            pure $ AttrName v+          ]     ]  pAttrs :: Parser Attrs@@ -363,7 +367,7 @@ pBranchTypes pr = braces $ pBranchType pr `sepBy` pComma  pParam :: Parser t -> Parser (Param t)-pParam p = Param <$> pVName <*> (pColon *> p)+pParam p = Param <$> pAttrs <*> pVName <*> (pColon *> p)  pFParam :: PR rep -> Parser (FParam rep) pFParam = pParam . pFParamInfo

@@ -111,7 +111,8 @@         </> text "in" <+> braces (commasep $ map ppr res)  instance Pretty Attr where-  ppr (AttrAtom v) = ppr v+  ppr (AttrName v) = ppr v+  ppr (AttrInt x) = ppr x   ppr (AttrComp f attrs) = ppr f <> parens (commasep $ map ppr attrs)  attrAnnots :: Attrs -> [Doc]@@ -140,7 +141,8 @@   ppr (PatElem name t) = ppr name <+> colon <+> align (ppr t)  instance Pretty t => Pretty (Param t) where-  ppr (Param name t) = ppr name <+> colon <+> align (ppr t)+  ppr (Param attrs name t) =+    annot (attrAnnots attrs) $ ppr name <+> colon <+> align (ppr t)  instance PrettyRep rep => Pretty (Stm rep) where   ppr stm@(Let pat aux e) =

@@ -335,7 +335,7 @@   freeIn' (Acc acc ispace ts _) = freeIn' (acc, ispace, ts)  instance FreeIn dec => FreeIn (Param dec) where-  freeIn' (Param _ dec) = freeIn' dec+  freeIn' (Param attrs _ dec) = freeIn' attrs <> freeIn' dec  instance FreeIn dec => FreeIn (PatElemT dec) where   freeIn' (PatElem _ dec) = freeIn' dec

@@ -18,6 +18,7 @@     simplifyKnownIterationSOAC,     removeReplicateMapping,     liftIdentityMapping,+    simplifyMapIota,     SOACS,   ) where@@ -257,10 +258,10 @@  liftIdentityMapping ::   forall rep.-  (Buildable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) =>-  TopDownRuleOp (Wise rep)+  (Buildable rep, BuilderOps rep, HasSOAC rep) =>+  TopDownRuleOp rep liftIdentityMapping _ pat aux op-  | Just (Screma w arrs form :: SOAC (Wise rep)) <- asSOAC op,+  | Just (Screma w arrs form :: SOAC rep) <- asSOAC op,     Just fun <- isMapSOAC form = do     let inputMap = M.fromList $ zip (map paramName $ lambdaParams fun) arrs         free = freeIn $ lambdaBody fun@@ -343,8 +344,8 @@ -- | Remove all arguments to the map that are simply replicates. -- These can be turned into free variables instead. removeReplicateMapping ::-  (Buildable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) =>-  TopDownRuleOp (Wise rep)+  (Aliased rep, Buildable rep, BuilderOps rep, HasSOAC rep) =>+  TopDownRuleOp rep removeReplicateMapping vtable pat aux op   | Just (Screma w arrs form) <- asSOAC op,     Just fun <- isMapSOAC form,@@ -418,9 +419,8 @@     let ses = bodyResult $ lambdaBody fun         isUsed (bindee, _, _) = (`UT.used` used) $ patElemName bindee         (pat', ses', ts') =-          unzip3 $-            filter isUsed $-              zip3 (patElems pat) ses $ lambdaReturnType fun+          unzip3 . filter isUsed . zip3 (patElems pat) ses $+            lambdaReturnType fun         fun' =           fun             { lambdaBody = (lambdaBody fun) {bodyResult = ses'},@@ -472,46 +472,26 @@     let redim           | isJust $ shapeCoercion newshape = DimCoercion w           | otherwise = DimNew w-    certifying (stmAuxCerts aux1 <> cs) $-      letBind pat $-        BasicOp $ Reshape (redim : newshape) arr-  | Just-      ( _,-        cs,-        _,-        BasicOp (Concat d arr arrs dw),-        ps,-        outer_arr : outer_arrs-        ) <-+    certifying (stmAuxCerts aux1 <> cs) . letBind pat . BasicOp $+      Reshape (redim : newshape) arr+  | Just (_, cs, _, BasicOp (Concat d arr arrs dw), ps, outer_arr : outer_arrs) <-       isMapWithOp pat e,     (arr : arrs) == map paramName ps =-    Simplify $-      certifying (stmAuxCerts aux1 <> cs) $-        letBind pat $-          BasicOp $ Concat (d + 1) outer_arr outer_arrs dw+    Simplify . certifying (stmAuxCerts aux1 <> cs) . letBind pat . BasicOp $+      Concat (d + 1) outer_arr outer_arrs dw   | Just-      ( map_pe,-        cs,-        _,-        BasicOp (Rearrange perm rearrange_arr),-        [p],-        [arr]-        ) <-+      (map_pe, cs, _, BasicOp (Rearrange perm rearrange_arr), [p], [arr]) <-       isMapWithOp pat e,     paramName p == rearrange_arr,     not $ UT.isConsumed (patElemName map_pe) used =-    Simplify $-      certifying (stmAuxCerts aux1 <> cs) $-        letBind pat $-          BasicOp $ Rearrange (0 : map (1 +) perm) arr+    Simplify . certifying (stmAuxCerts aux1 <> cs) . letBind pat . BasicOp $+      Rearrange (0 : map (1 +) perm) arr   | Just (map_pe, cs, _, BasicOp (Rotate rots rotate_arr), [p], [arr]) <-       isMapWithOp pat e,     paramName p == rotate_arr,     not $ UT.isConsumed (patElemName map_pe) used =-    Simplify $-      certifying (stmAuxCerts aux1 <> cs) $-        letBind pat $-          BasicOp $ Rotate (intConst Int64 0 : rots) arr+    Simplify . certifying (stmAuxCerts aux1 <> cs) . letBind pat . BasicOp $+      Rotate (intConst Int64 0 : rots) arr mapOpToOp _ _ _ _ = Skip  isMapWithOp ::@@ -529,8 +509,7 @@   | Pat [map_pe] <- pat,     Screma w arrs form <- e,     Just map_lam <- isMapSOAC form,-    [Let (Pat [pe]) aux2 e'] <--      stmsToList $ bodyStms $ lambdaBody map_lam,+    [Let (Pat [pe]) aux2 e'] <- stmsToList $ bodyStms $ lambdaBody map_lam,     [SubExpRes _ (Var r)] <- bodyResult $ lambdaBody map_lam,     r == patElemName pe =     Just (map_pe, stmAuxCerts aux2, w, e', lambdaParams map_lam, arrs)@@ -549,9 +528,8 @@     let redlam_res = bodyResult $ lambdaBody redlam,     let redlam_params = lambdaParams redlam,     let used_after =-          map snd $-            filter ((`UT.used` used) . patElemName . fst) $-              zip red_pes redlam_params,+          map snd . filter ((`UT.used` used) . patElemName . fst) $+            zip red_pes redlam_params,     let necessary =           findNecessaryForReturned             (`elem` used_after)@@ -562,9 +540,8 @@     let fixDeadToNeutral lives ne = if lives then Nothing else Just ne         dead_fix = zipWith fixDeadToNeutral alive_mask nes         (used_red_pes, _, used_nes) =-          unzip3 $-            filter (\(_, x, _) -> paramName x `nameIn` necessary) $-              zip3 red_pes redlam_params nes+          unzip3 . filter (\(_, x, _) -> paramName x `nameIn` necessary) $+            zip3 red_pes redlam_params nes      let maplam' = removeLambdaResults (take (length nes) alive_mask) maplam     redlam' <- removeLambdaResults (take (length nes) alive_mask) <$> fixLambdaParams redlam (dead_fix ++ dead_fix)@@ -581,9 +558,7 @@       (i_ts, v_ts) = unzip $ groupScatterResults' dests $ lambdaReturnType fun       isUsed (bindee, _, _, _, _, _) = (`UT.used` used) $ patElemName bindee       (pat', i_ses', v_ses', i_ts', v_ts', dests') =-        unzip6 $-          filter isUsed $-            zip6 (patElems pat) i_ses v_ses i_ts v_ts dests+        unzip6 $ filter isUsed $ zip6 (patElems pat) i_ses v_ses i_ts v_ts dests       fun' =         fun           { lambdaBody = (lambdaBody fun) {bodyResult = concat i_ses' ++ v_ses'},@@ -604,30 +579,21 @@     xivs <- transpose xss,     all (w' ==) ws = Simplify $ do     let r = length xivs-    fun2s <- mapM (\_ -> renameLambda fun) [1 .. r -1]+    fun2s <- replicateM (r -1) (renameLambda fun)     let (fun_is, fun_vs) =-          unzip $-            map-              ( splitScatterResults dests-                  . bodyResult-                  . lambdaBody-              )-              (fun : fun2s)+          unzip . map (splitScatterResults dests . bodyResult . lambdaBody) $+            fun : fun2s         (its, vts) =-          unzip $-            replicate r $-              splitScatterResults dests $ lambdaReturnType fun+          unzip . replicate r . splitScatterResults dests $ lambdaReturnType fun         new_stmts = mconcat $ map (bodyStms . lambdaBody) (fun : fun2s)     let fun' =           Lambda             { lambdaParams = mconcat $ map lambdaParams (fun : fun2s),-              lambdaBody =-                mkBody new_stmts $-                  mix fun_is <> mix fun_vs,+              lambdaBody = mkBody new_stmts $ mix fun_is <> mix fun_vs,               lambdaReturnType = mix its <> mix vts             }-    certifying (mconcat css) $-      letBind pat $ Op $ Scatter w' fun' (concat xivs) $ map (incWrites r) dests+    certifying (mconcat css) . letBind pat . Op $+      Scatter w' fun' (concat xivs) $ map (incWrites r) dests   where     sizeOf :: VName -> Maybe SubExp     sizeOf x = arraySize 0 . typeOf <$> ST.lookup x vtable@@ -650,9 +616,8 @@ simplifyClosedFormReduce _ pat _ (Screma (Constant w) _ form)   | Just nes <- concatMap redNeutral . fst <$> isRedomapSOAC form,     zeroIsh w =-    Simplify $-      forM_ (zip (patNames pat) nes) $ \(v, ne) ->-        letBindNames [v] $ BasicOp $ SubExp ne+    Simplify . forM_ (zip (patNames pat) nes) $ \(v, ne) ->+      letBindNames [v] $ BasicOp $ SubExp ne simplifyClosedFormReduce vtable pat _ (Screma _ arrs form)   | Just [Reduce _ red_fun nes] <- isReduceSOAC form =     Simplify $ foldClosedForm (`ST.lookupExp` vtable) pat red_fun nes arrs@@ -660,8 +625,8 @@  -- For now we just remove singleton SOACs. simplifyKnownIterationSOAC ::-  (Buildable rep, Simplify.SimplifiableRep rep, HasSOAC (Wise rep)) =>-  TopDownRuleOp (Wise rep)+  (Buildable rep, BuilderOps rep, HasSOAC rep) =>+  TopDownRuleOp rep simplifyKnownIterationSOAC _ pat _ op   | Just (Screma (Constant k) arrs (ScremaForm scans reds map_lam)) <- asSOAC op,     oneIsh k = Simplify $ do@@ -734,7 +699,7 @@ arrayOpCerts (ArrayCopy cs _) = cs arrayOpCerts (ArrayVar cs _) = cs -isArrayOp :: Certs -> AST.Exp (Wise SOACS) -> Maybe ArrayOp+isArrayOp :: Certs -> AST.Exp rep -> Maybe ArrayOp isArrayOp cs (BasicOp (Index arr slice)) =   Just $ ArrayIndexing cs arr slice isArrayOp cs (BasicOp (Rearrange perm arr)) =@@ -746,21 +711,32 @@ isArrayOp _ _ =   Nothing -fromArrayOp :: ArrayOp -> (Certs, AST.Exp (Wise SOACS))+fromArrayOp :: ArrayOp -> (Certs, AST.Exp rep) fromArrayOp (ArrayIndexing cs arr slice) = (cs, BasicOp $ Index arr slice) fromArrayOp (ArrayRearrange cs arr perm) = (cs, BasicOp $ Rearrange perm arr) fromArrayOp (ArrayRotate cs arr rots) = (cs, BasicOp $ Rotate rots arr) fromArrayOp (ArrayCopy cs arr) = (cs, BasicOp $ Copy arr) fromArrayOp (ArrayVar cs arr) = (cs, BasicOp $ SubExp $ Var arr) -arrayOps :: AST.Body (Wise SOACS) -> S.Set (AST.Pat (Wise SOACS), ArrayOp)+arrayOps ::+  forall rep.+  (Buildable rep, HasSOAC rep) =>+  AST.Body rep ->+  S.Set (AST.Pat rep, ArrayOp) arrayOps = mconcat . map onStm . stmsToList . bodyStms   where     onStm (Let pat aux e) =       case isArrayOp (stmAuxCerts aux) e of         Just op -> S.singleton (pat, op)         Nothing -> execState (walkExpM walker e) mempty-    onOp = execWriter . mapSOACM identitySOACMapper {mapOnSOACLambda = onLambda}+    onOp op+      | Just soac <- asSOAC op =+        execWriter $+          mapSOACM+            identitySOACMapper {mapOnSOACLambda = onLambda}+            (soac :: SOAC rep)+      | otherwise =+        mempty     onLambda lam = do       tell $ arrayOps $ lambdaBody lam       return lam@@ -771,9 +747,11 @@         }  replaceArrayOps ::+  forall rep.+  (Buildable rep, BuilderOps rep, HasSOAC rep) =>   M.Map ArrayOp ArrayOp ->-  AST.Body (Wise SOACS) ->-  AST.Body (Wise SOACS)+  AST.Body rep ->+  AST.Body rep replaceArrayOps substs (Body _ stms res) =   mkBody (fmap onStm stms) res   where@@ -790,7 +768,12 @@         { mapOnBody = const $ return . replaceArrayOps substs,           mapOnOp = return . onOp         }-    onOp = runIdentity . mapSOACM identitySOACMapper {mapOnSOACLambda = return . onLambda}+    onOp op+      | Just (soac :: SOAC rep) <- asSOAC op =+        soacOp . runIdentity $+          mapSOACM identitySOACMapper {mapOnSOACLambda = return . onLambda} soac+      | otherwise =+        op     onLambda lam = lam {lambdaBody = replaceArrayOps substs $ lambdaBody lam}  -- Turn@@ -808,58 +791,75 @@ -- case - if you find yourself planning to extend it to handle more -- complex situations (rotate or whatnot), consider turning it into a -- separate compiler pass instead.-simplifyMapIota :: TopDownRuleOp (Wise SOACS)-simplifyMapIota vtable pat aux (Screma w arrs (ScremaForm scan reduce map_lam))-  | Just (p, _) <- find isIota (zip (lambdaParams map_lam) arrs),+simplifyMapIota ::+  forall rep.+  (Buildable rep, BuilderOps rep, HasSOAC rep) =>+  TopDownRuleOp rep+simplifyMapIota vtable pat aux op+  | Just (Screma w arrs (ScremaForm scan reduce map_lam) :: SOAC rep) <- asSOAC op,+    Just (p, _) <- find isIota (zip (lambdaParams map_lam) arrs),     indexings <--      filter (indexesWith (paramName p)) $-        map snd $-          S.toList $-            arrayOps $ lambdaBody map_lam,+      mapMaybe (indexesWith (paramName p) . snd) . S.toList $+        arrayOps $ lambdaBody map_lam,     not $ null indexings = Simplify $ do     -- For each indexing with iota, add the corresponding array to     -- the Screma, and construct a new lambda parameter.     (more_arrs, more_params, replacements) <--      unzip3 . catMaybes <$> mapM mapOverArr indexings-    let substs = M.fromList $ zip indexings replacements+      unzip3 . catMaybes <$> mapM (mapOverArr w) indexings+    let substs = M.fromList replacements         map_lam' =           map_lam             { lambdaParams = lambdaParams map_lam <> more_params,-              lambdaBody =-                replaceArrayOps substs $-                  lambdaBody map_lam+              lambdaBody = replaceArrayOps substs $ lambdaBody map_lam             } -    auxing aux $-      letBind pat $ Op $ Screma w (arrs <> more_arrs) (ScremaForm scan reduce map_lam')+    auxing aux . letBind pat . Op . soacOp $+      Screma w (arrs <> more_arrs) (ScremaForm scan reduce map_lam')   where     isIota (_, arr) = case ST.lookupBasicOp arr vtable of       Just (Iota _ (Constant o) (Constant s) _, _) ->         zeroIsh o && oneIsh s       _ -> False -    indexesWith v (ArrayIndexing cs arr (Slice (DimFix (Var i) : _)))+    -- Find a 'DimFix i', optionally preceded by other DimFixes, and+    -- if so return those DimFixes.+    fixWith i (DimFix j : slice)+      | Var i == j = Just []+      | otherwise = (j :) <$> fixWith i slice+    fixWith _ _ = Nothing++    indexesWith v idx@(ArrayIndexing cs arr (Slice js))       | arr `ST.elem` vtable,-        all (`ST.elem` vtable) $ unCerts cs =-        i == v-    indexesWith _ _ = False+        all (`ST.elem` vtable) $ unCerts cs,+        Just js' <- fixWith v js,+        all (`ST.elem` vtable) $ namesToList $ freeIn js' =+        Just (js', idx)+    indexesWith _ _ = Nothing -    mapOverArr (ArrayIndexing cs arr slice) = do-      arr_elem <- newVName $ baseString arr ++ "_elem"+    properArr [] arr = pure arr+    properArr js arr = do       arr_t <- lookupType arr-      arr' <-+      letExp (baseString arr) $ BasicOp $ Index arr $ fullSlice arr_t $ map DimFix js++    mapOverArr w (js, ArrayIndexing cs arr slice) = do+      arr' <- properArr js arr+      arr_t <- lookupType arr'+      arr'' <-         if arraySize 0 arr_t == w-          then return arr+          then pure arr'           else-            certifying cs . letExp (baseString arr ++ "_prefix") . BasicOp . Index arr $+            certifying cs . letExp (baseString arr ++ "_prefix") . BasicOp . Index arr' $               fullSlice arr_t [DimSlice (intConst Int64 0) w (intConst Int64 1)]-      return $+      arr_elem_param <- newParam (baseString arr ++ "_elem") (rowType arr_t)+      pure $         Just-          ( arr',-            Param arr_elem (rowType arr_t),-            ArrayIndexing cs arr_elem (Slice (drop 1 (unSlice slice)))+          ( arr'',+            arr_elem_param,+            ( ArrayIndexing cs arr slice,+              ArrayIndexing cs (paramName arr_elem_param) (Slice (drop (length js + 1) (unSlice slice)))+            )           )-    mapOverArr _ = return Nothing+    mapOverArr _ _ = return Nothing simplifyMapIota _ _ _ _ = Skip  -- If a Screma's map function contains a transformation@@ -936,7 +936,7 @@         return $           Just             ( arr_transformed,-              Param arr_transformed_row (rowType arr_transformed_t),+              Param mempty arr_transformed_row (rowType arr_transformed_t),               ArrayVar mempty arr_transformed_row             )     mapOverArr _ = return Nothing

@@ -766,12 +766,11 @@     }  mapOnSegSpace ::-  Monad f =>-  SegOpMapper lvl frep trep f ->-  SegSpace ->-  f SegSpace+  Monad f => SegOpMapper lvl frep trep f -> SegSpace -> f SegSpace mapOnSegSpace tv (SegSpace phys dims) =-  SegSpace phys <$> traverse (traverse $ mapOnSegOpSubExp tv) dims+  SegSpace+    <$> mapOnSegOpVName tv phys+    <*> traverse (bitraverse (mapOnSegOpVName tv) (mapOnSegOpSubExp tv)) dims  mapSegBinOp ::   Monad m =>@@ -857,11 +856,9 @@             mapOnSegOpLevel = return . substituteNames subst           } -instance-  (ASTRep rep, ASTConstraints lvl) =>-  Rename (SegOp lvl rep)-  where-  rename = mapSegOpM renamer+instance (ASTRep rep, ASTConstraints lvl) => Rename (SegOp lvl rep) where+  rename op =+    renameBound (M.keys (scopeOfSegSpace (segSpace op))) $ mapSegOpM renamer op     where       renamer = SegOpMapper rename rename rename rename rename @@ -869,7 +866,9 @@   (ASTRep rep, FreeIn (LParamInfo rep), FreeIn lvl) =>   FreeIn (SegOp lvl rep)   where-  freeIn' e = flip execState mempty $ mapSegOpM free e+  freeIn' e =+    fvBind (namesFromList $ M.keys $ scopeOfSegSpace (segSpace e)) $+      flip execState mempty $ mapSegOpM free e     where       walk f x = modify (<> f x) >> return x       free =

@@ -50,7 +50,7 @@   checkLParamDec = checkMemInfo   checkLetBoundDec = checkMemInfo   checkRetType = mapM_ (TC.checkExtType . declExtTypeOf)-  primFParam name t = return $ Param name (MemPrim t)+  primFParam name t = return $ Param mempty name (MemPrim t)   matchPat = matchPatToExp   matchReturnType = matchFunctionReturnType   matchBranchType = matchBranchReturnType

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Strict #-} {-# LANGUAGE Trustworthy #-}@@ -111,13 +110,6 @@     TypeBase (..),     Diet (..), -    -- * Attributes-    Attr (..),-    Attrs (..),-    oneAttr,-    inAttrs,-    withoutAttrs,-     -- * Abstract syntax tree     Ident (..),     SubExp (..),@@ -174,7 +166,6 @@ import Control.Category import Data.Foldable import qualified Data.Sequence as Seq-import qualified Data.Set as S import Data.String import Data.Traversable (fmapDefault, foldMapDefault) import Futhark.IR.Rep@@ -182,32 +173,6 @@ import Futhark.Util.Pretty (pretty) import Language.Futhark.Core import Prelude hiding (id, (.))---- | A single attribute.-data Attr-  = AttrAtom Name-  | AttrComp Name [Attr]-  deriving (Ord, Show, Eq)--instance IsString Attr where-  fromString = AttrAtom . fromString---- | Every statement is associated with a set of attributes, which can--- have various effects throughout the compiler.-newtype Attrs = Attrs {unAttrs :: S.Set Attr}-  deriving (Ord, Show, Eq, Monoid, Semigroup)---- | Construct 'Attrs' from a single 'Attr'.-oneAttr :: Attr -> Attrs-oneAttr = Attrs . S.singleton---- | Is the given attribute to be found in the attribute set?-inAttrs :: Attr -> Attrs -> Bool-inAttrs attr (Attrs attrs) = attr `S.member` attrs---- | @x `withoutAttrs` y@ gives @x@ except for any attributes also in @y@.-withoutAttrs :: Attrs -> Attrs -> Attrs-withoutAttrs (Attrs x) (Attrs y) = Attrs $ x `S.difference` y  -- | A type alias for namespace control. type PatElem rep = PatElemT (LetDec rep)

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} @@ -35,6 +36,13 @@     ErrorMsgPart (..),     errorMsgArgTypes, +    -- * Attributes+    Attr (..),+    Attrs (..),+    oneAttr,+    inAttrs,+    withoutAttrs,+     -- * Values     PrimValue (..), @@ -68,6 +76,7 @@ import Data.Bitraversable import qualified Data.Map.Strict as M import Data.Maybe+import qualified Data.Set as S import Data.String import Data.Traversable (fmapDefault, foldMapDefault) import Futhark.IR.Primitive@@ -306,7 +315,10 @@  -- | A function or lambda parameter. data Param dec = Param-  { -- | Name of the parameter.+  { -- | Attributes of the parameter.  When constructing a parameter,+    -- feel free to just pass 'mempty'.+    paramAttrs :: Attrs,+    -- | Name of the parameter.     paramName :: VName,     -- | Function parameter decoration.     paramDec :: dec@@ -320,7 +332,7 @@   fmap = fmapDefault  instance Traversable Param where-  traverse f (Param name dec) = Param name <$> f dec+  traverse f (Param attr name dec) = Param attr name <$> f dec  -- | How to index a single dimension of an array. data DimIndex d@@ -508,3 +520,30 @@   where     onPart ErrorString {} = Nothing     onPart (ErrorVal t _) = Just t++-- | A single attribute.+data Attr+  = AttrName Name+  | AttrInt Integer+  | AttrComp Name [Attr]+  deriving (Ord, Show, Eq)++instance IsString Attr where+  fromString = AttrName . fromString++-- | Every statement is associated with a set of attributes, which can+-- have various effects throughout the compiler.+newtype Attrs = Attrs {unAttrs :: S.Set Attr}+  deriving (Ord, Show, Eq, Monoid, Semigroup)++-- | Construct 'Attrs' from a single 'Attr'.+oneAttr :: Attr -> Attrs+oneAttr = Attrs . S.singleton++-- | Is the given attribute to be found in the attribute set?+inAttrs :: Attr -> Attrs -> Bool+inAttrs attr (Attrs attrs) = attr `S.member` attrs++-- | @x `withoutAttrs` y@ gives @x@ except for any attributes also in @y@.+withoutAttrs :: Attrs -> Attrs -> Attrs+withoutAttrs (Attrs x) (Attrs y) = Attrs $ x `S.difference` y

@@ -3,7 +3,9 @@  -- | Internalising bindings. module Futhark.Internalise.Bindings-  ( bindingFParams,+  ( internaliseAttrs,+    internaliseAttr,+    bindingFParams,     bindingLoopParams,     bindingLambdaParams,     stmPat,@@ -11,6 +13,7 @@ where  import Control.Monad.Reader hiding (mapM)+import Data.Bifunctor import qualified Data.Map.Strict as M import Data.Maybe import qualified Futhark.IR.SOACS as I@@ -19,6 +22,17 @@ import Futhark.Util import Language.Futhark as E hiding (matchDims) +internaliseAttr :: E.AttrInfo VName -> InternaliseM I.Attr+internaliseAttr (E.AttrAtom (E.AtomName v) _) =+  pure $ I.AttrName v+internaliseAttr (E.AttrAtom (E.AtomInt x) _) =+  pure $ I.AttrInt x+internaliseAttr (E.AttrComp f attrs _) =+  I.AttrComp f <$> mapM internaliseAttr attrs++internaliseAttrs :: [E.AttrInfo VName] -> InternaliseM I.Attrs+internaliseAttrs = fmap (mconcat . map I.oneAttr) . mapM internaliseAttr+ bindingFParams ::   [E.TypeParam] ->   [E.Pat] ->@@ -29,11 +43,11 @@   let params_idents = concat flattened_params   params_ts <-     internaliseParamTypes $-      map (flip E.setAliases () . E.unInfo . E.identType) params_idents+      map (flip E.setAliases () . E.unInfo . E.identType . fst) params_idents   let num_param_idents = map length flattened_params       num_param_ts = map (sum . map length) $ chunks num_param_idents params_ts -  let shape_params = [I.Param v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams]+  let shape_params = [I.Param mempty v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams]       shape_subst = M.fromList [(I.paramName p, [I.Var $ I.paramName p]) | p <- shape_params]   bindingFlatPat params_idents (concat params_ts) $ \valueparams -> do     let (certparams, valueparams') = unzip $ map fixAccParam (concat valueparams)@@ -41,9 +55,9 @@       substitutingVars shape_subst $         m (catMaybes certparams ++ shape_params) $ chunks num_param_ts valueparams'   where-    fixAccParam (I.Param pv (I.Acc acc ispace ts u)) =-      ( Just (I.Param acc $ I.Prim I.Unit),-        I.Param pv (I.Acc acc ispace ts u)+    fixAccParam (I.Param attrs pv (I.Acc acc ispace ts u)) =+      ( Just (I.Param attrs acc $ I.Prim I.Unit),+        I.Param attrs pv (I.Acc acc ispace ts u)       )     fixAccParam p = (Nothing, p) @@ -57,7 +71,7 @@   pat_idents <- flattenPat pat   pat_ts <- internaliseLoopParamType (E.patternStructType pat) ts -  let shape_params = [I.Param v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams]+  let shape_params = [I.Param mempty v $ I.Prim I.int64 | E.TypeParamDim v _ <- tparams]       shape_subst = M.fromList [(I.paramName p, [I.Var $ I.paramName p]) | p <- shape_params]    bindingFlatPat pat_idents pat_ts $ \valueparams ->@@ -77,7 +91,7 @@  processFlatPat ::   Show t =>-  [E.Ident] ->+  [(E.Ident, [E.AttrInfo VName])] ->   [t] ->   InternaliseM ([[I.Param t]], VarSubsts) processFlatPat x y = processFlatPat' [] x y@@ -85,16 +99,17 @@     processFlatPat' pat [] _ = do       let (vs, substs) = unzip pat       return (reverse vs, M.fromList substs)-    processFlatPat' pat (p : rest) ts = do-      (ps, rest_ts) <- handleMapping ts <$> internaliseBindee p+    processFlatPat' pat ((p, attrs) : rest) ts = do+      attrs' <- internaliseAttrs attrs+      (ps, rest_ts) <- handleMapping attrs' ts <$> internaliseBindee p       processFlatPat' ((ps, (E.identName p, map (I.Var . I.paramName) ps)) : pat) rest rest_ts -    handleMapping ts [] =+    handleMapping _ ts [] =       ([], ts)-    handleMapping (t : ts) (r : rs) =-      let (ps, ts') = handleMapping ts rs-       in (I.Param r t : ps, ts')-    handleMapping [] _ =+    handleMapping attrs (t : ts) (r : rs) =+      let (ps, ts') = handleMapping attrs ts rs+       in (I.Param attrs r t : ps, ts')+    handleMapping _ [] _ =       error $ "handleMapping: insufficient identifiers in pattern." ++ show (x, y)      internaliseBindee :: E.Ident -> InternaliseM [VName]@@ -107,7 +122,7 @@  bindingFlatPat ::   Show t =>-  [E.Ident] ->+  [(E.Ident, [E.AttrInfo VName])] ->   [t] ->   ([[I.Param t]] -> InternaliseM a) ->   InternaliseM a@@ -117,16 +132,18 @@     m ps  -- | Flatten a pattern.  Returns a list of identifiers.-flattenPat :: MonadFreshNames m => E.Pat -> m [E.Ident]+flattenPat :: MonadFreshNames m => E.Pat -> m [(E.Ident, [E.AttrInfo VName])] flattenPat = flattenPat'   where     flattenPat' (E.PatParens p _) =       flattenPat' p+    flattenPat' (E.PatAttr attr p _) =+      map (second (attr :)) <$> flattenPat' p     flattenPat' (E.Wildcard t loc) = do       name <- newVName "nameless"       flattenPat' $ E.Id name t loc     flattenPat' (E.Id v (Info t) loc) =-      return [E.Ident v (Info t) loc]+      return [(E.Ident v (Info t) loc, mempty)]     -- XXX: treat empty tuples and records as unit.     flattenPat' (E.TuplePat [] loc) =       flattenPat' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc)

@@ -27,7 +27,7 @@ -- | An expression or an extended 'Lambda' (with size parameters, -- which AST lambdas do not support). data ExtExp-  = ExtLambda [Pat] Exp StructType SrcLoc+  = ExtLambda [Pat] Exp StructRetType SrcLoc   | ExtExp Exp   deriving (Show) @@ -35,7 +35,7 @@ -- defunctionalization of an expression, aside from the residual expression. data StaticVal   = Dynamic PatType-  | LambdaSV Pat StructType ExtExp Env+  | LambdaSV Pat StructRetType ExtExp Env   | RecordSV [(Name, StaticVal)]   | -- | The constructor that is actually present, plus     -- the others that are not.@@ -96,13 +96,13 @@ replaceStaticValSizes globals orig_substs sv =   case sv of     _ | M.null orig_substs -> sv-    LambdaSV param t e closure_env ->+    LambdaSV param (RetType t_dims t) e closure_env ->       let substs =             foldl' (flip M.delete) orig_substs $               S.fromList (M.keys closure_env)        in LambdaSV             (onAST substs param)-            (replaceTypeSizes substs t)+            (RetType t_dims (replaceTypeSizes substs t))             (onExtExp substs e)             (onEnv orig_substs closure_env) --intentional     Dynamic t ->@@ -178,13 +178,19 @@       TERecord (map (fmap $ onTypeExp substs) ts) loc     onTypeExp substs (TESum ts loc) =       TESum (map (fmap $ map $ onTypeExp substs) ts) loc+    onTypeExp substs (TEDim dims t loc) =+      TEDim dims (onTypeExp substs t) loc     onTypeExp _ (TEVar v loc) =       TEVar v loc      onExtExp substs (ExtExp e) =       ExtExp $ onExp substs e-    onExtExp substs (ExtLambda params e t loc) =-      ExtLambda (map (onAST substs) params) (onExp substs e) (replaceTypeSizes substs t) loc+    onExtExp substs (ExtLambda params e (RetType t_dims t) loc) =+      ExtLambda+        (map (onAST substs) params)+        (onExp substs e)+        (RetType t_dims (replaceTypeSizes substs t))+        loc      onEnv substs =       M.fromList@@ -305,13 +311,15 @@   M.Map VName SizeSubst dimMapping t1 t2 = execState (matchDims f t1 t2) mempty   where-    f (NamedDim d1) (NamedDim d2) = do+    f bound d1 (NamedDim d2)+      | qualLeaf d2 `elem` bound = pure d1+    f _ (NamedDim d1) (NamedDim d2) = do       modify $ M.insert (qualLeaf d1) $ SubstNamed d2-      return $ NamedDim d1-    f (NamedDim d1) (ConstDim d2) = do+      pure $ NamedDim d1+    f _ (NamedDim d1) (ConstDim d2) = do       modify $ M.insert (qualLeaf d1) $ SubstConst d2-      return $ NamedDim d1-    f d _ = return d+      pure $ NamedDim d1+    f _ d _ = pure d  dimMapping' ::   Monoid a =>@@ -377,7 +385,7 @@   [VName] ->   [Pat] ->   Exp ->-  StructType ->+  StructRetType ->   SrcLoc ->   DefM (Exp, StaticVal) defuncFun tparams pats e0 ret loc = do@@ -388,7 +396,7 @@         [pat'] -> (pat', ret, ExtExp e0)         (pat' : pats') ->           ( pat',-            foldFunType (map (toStruct . patternType) pats') ret,+            RetType [] $ foldFunType (map (toStruct . patternType) pats') ret,             ExtLambda pats' e0 ret loc           ) @@ -706,9 +714,9 @@     return $ Lambda pats body' Nothing (Info (mempty, tp)) mempty   | otherwise = defuncExp' e -etaExpand :: PatType -> Exp -> DefM ([Pat], Exp, StructType)+etaExpand :: PatType -> Exp -> DefM ([Pat], Exp, StructRetType) etaExpand e_t e = do-  let (ps, ret) = getType e_t+  let (ps, ret) = getType $ RetType [] e_t   (pats, vars) <- fmap unzip . forM ps $ \(p, t) -> do     x <- case p of       Named x -> pure x@@ -726,9 +734,9 @@           )           e           $ zip3 vars (map snd ps) (drop 1 $ tails $ map snd ps)-  return (pats, e', toStruct ret)+  return (pats, e', second (const ()) ret)   where-    getType (Scalar (Arrow _ p t1 t2)) =+    getType (RetType _ (Scalar (Arrow _ p t1 t2))) =       let (ps, r) = getType t2 in ((p, t1) : ps, r)     getType t = ([], t) @@ -746,16 +754,17 @@   [VName] ->   [Pat] ->   Exp ->-  StructType ->+  StructRetType ->   DefM ([VName], [Pat], Exp, StaticVal)-defuncLet dims ps@(pat : pats) body rettype+defuncLet dims ps@(pat : pats) body (RetType ret_dims rettype)   | patternOrderZero pat = do     let bound_by_pat = (`S.member` patternDimNames pat)         -- Take care to not include more size parameters than necessary.         (pat_dims, rest_dims) = partition bound_by_pat dims         env = envFromPat pat <> envFromDimNames pat_dims-    (rest_dims', pats', body', sv) <- localEnv env $ defuncLet rest_dims pats body rettype-    closure <- defuncFun dims ps body rettype mempty+    (rest_dims', pats', body', sv) <-+      localEnv env $ defuncLet rest_dims pats body $ RetType ret_dims rettype+    closure <- defuncFun dims ps body (RetType ret_dims rettype) mempty     return       ( pat_dims ++ rest_dims',         pat : pats',@@ -763,9 +772,9 @@         DynamicFun closure sv       )   | otherwise = do-    (e, sv) <- defuncFun dims ps body rettype mempty+    (e, sv) <- defuncFun dims ps body (RetType ret_dims rettype) mempty     return ([], [], e, sv)-defuncLet _ [] body rettype = do+defuncLet _ [] body (RetType _ rettype) = do   (body', sv) <- defuncExp body   return ([], [], body', imposeType sv rettype)   where@@ -795,6 +804,13 @@       pure $ NamedDim d     onDim d = pure d +unRetType :: StructRetType -> StructType+unRetType (RetType [] t) = t+unRetType (RetType ext t) = first onDim t+  where+    onDim (NamedDim d) | qualLeaf d `elem` ext = AnyDim Nothing+    onDim d = d+ -- | Defunctionalize an application expression at a given depth of application. -- Calls to dynamic (first-order) functions are preserved at much as possible, -- but a new lifted function is created if a dynamic function is only partially@@ -826,7 +842,7 @@           params_for_rettype = params ++ svParams sv1 ++ svParams sv2           svParams (LambdaSV sv_pat _ _ _) = [sv_pat]           svParams _ = []-          rettype = buildRetType closure_env params_for_rettype e0_t $ typeOf e0'+          rettype = buildRetType closure_env params_for_rettype (unRetType e0_t) $ typeOf e0'            already_bound =             globals <> S.fromList dims@@ -855,7 +871,7 @@       fname <- newNameFromString $ liftedName (0 :: Int) e1       liftValDec         fname-        rettype+        (RetType [] $ toStruct rettype)         (dims ++ more_dims ++ missing_dims)         params'         e0'@@ -869,7 +885,10 @@               ( Info                   ( Scalar $                       Arrow mempty Unnamed (fromStruct t1) $-                        Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype+                        RetType [] $+                          Scalar $+                            Arrow mempty Unnamed (fromStruct t2) $+                              RetType [] rettype                   )               )               loc@@ -886,7 +905,14 @@                 ( Apply                     ( AppExp                         (Apply fname'' e1' (Info (Observe, Nothing)) loc)-                        (Info $ AppRes (Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype) [])+                        ( Info $+                            AppRes+                              ( Scalar $+                                  Arrow mempty Unnamed (fromStruct t2) $+                                    RetType [] rettype+                              )+                              []+                        )                     )                     e2'                     d@@ -903,7 +929,7 @@     -- a higher-order term.     DynamicFun _ sv -> do       let (argtypes', rettype) = dynamicFunType sv argtypes-          restype = foldFunType argtypes' rettype `setAliases` aliases ret+          restype = foldFunType argtypes' (RetType [] rettype) `setAliases` aliases ret           -- FIXME: what if this application returns both a function           -- and a value?           callret@@ -943,9 +969,9 @@         -- We still need to update the types in case the dynamic         -- function returns a higher-order term.         let (argtypes', rettype) = dynamicFunType sv argtypes-        return (Var qn (Info (foldFunType argtypes' rettype)) loc, sv)+        return (Var qn (Info (foldFunType argtypes' $ RetType [] rettype)) loc, sv)       | otherwise -> do-        fname <- newName $ qualLeaf qn+        fname <- newVName $ "dyn_" <> baseString (qualLeaf qn)         let (pats, e0, sv') = liftDynFun (pretty qn) sv depth             (argtypes', rettype) = dynamicFunType sv' argtypes             dims' = mempty@@ -957,11 +983,11 @@         let bound_sizes = S.fromList dims' <> globals         (missing_dims, pats') <- sizesForAll bound_sizes pats -        liftValDec fname (fromStruct rettype) (dims' ++ missing_dims) pats' e0+        liftValDec fname (RetType [] $ toStruct rettype) (dims' ++ missing_dims) pats' e0         return           ( Var               (qualName fname)-              (Info (foldFunType argtypes' $ fromStruct rettype))+              (Info (foldFunType argtypes' $ RetType [] $ fromStruct rettype))               loc,             sv'           )@@ -1003,6 +1029,7 @@   TuplePat ps _ -> foldMap envFromPat ps   RecordPat fs _ -> foldMap (envFromPat . snd) fs   PatParens p _ -> envFromPat p+  PatAttr _ p _ -> envFromPat p   Id vn (Info t) _ -> M.singleton vn $ Binding Nothing $ Dynamic t   Wildcard _ _ -> mempty   PatAscription p _ _ -> envFromPat p@@ -1016,8 +1043,8 @@  -- | Create a new top-level value declaration with the given function name, -- return type, list of parameters, and body expression.-liftValDec :: VName -> PatType -> [VName] -> [Pat] -> Exp -> DefM ()-liftValDec fname rettype dims pats body = addValBind dec+liftValDec :: VName -> StructRetType -> [VName] -> [Pat] -> Exp -> DefM ()+liftValDec fname (RetType ret_dims ret) dims pats body = addValBind dec   where     dims' = map (`TypeParamDim` mempty) dims     -- FIXME: this pass is still not correctly size-preserving, so@@ -1025,18 +1052,21 @@     -- the way.  Hopefully the internaliser is conservative and     -- will insert reshapes...     bound_here = S.fromList dims <> S.map identName (foldMap patIdents pats)-    anyDimIfNotBound (NamedDim v)-      | qualLeaf v `S.member` bound_here = NamedDim v-      | otherwise = AnyDim $ Just $ qualLeaf v-    anyDimIfNotBound d = d-    rettype_st = first anyDimIfNotBound $ toStruct rettype+    mkExt v+      | not $ v `S.member` bound_here = Just v+    mkExt _ = Nothing+    rettype_st = RetType (mapMaybe mkExt (S.toList (typeDimNames ret)) ++ ret_dims) ret +    (valbind_t, valbind_ext) =+      case pats of+        [] -> (RetType [] $ retType rettype_st, retDims rettype_st)+        _ -> (rettype_st, [])     dec =       ValBind         { valBindEntryPoint = Nothing,           valBindName = fname,           valBindRetDecl = Nothing,-          valBindRetType = Info (rettype_st, []),+          valBindRetType = Info (valbind_t, valbind_ext),           valBindTypeParams = dims',           valBindParams = pats,           valBindBody = body,@@ -1127,6 +1157,7 @@     map fst ps' == map fst ls' =     mconcat $ zipWith (\(_, p) (_, sv) -> matchPatSV p sv) ps' ls' matchPatSV (PatParens pat _) sv = matchPatSV pat sv+matchPatSV (PatAttr _ pat _) sv = matchPatSV pat sv matchPatSV (Id vn (Info t) _) sv =   -- When matching a pattern with a zero-order STaticVal, the type of   -- the pattern wins out.  This is important when matching a@@ -1179,6 +1210,8 @@       loc updatePat (PatParens pat loc) sv =   PatParens (updatePat pat sv) loc+updatePat (PatAttr attr pat loc) sv =+  PatAttr attr (updatePat pat sv) loc updatePat (Id vn (Info tp) loc) sv =   Id vn (Info $ comb tp (typeFromSV sv `setUniqueness` Nonunique)) loc   where@@ -1224,7 +1257,7 @@ -- boolean is true if the function is a 'DynamicFun'. defuncValBind :: ValBind -> DefM (ValBind, Env, Bool) -- Eta-expand entry points with a functional return type.-defuncValBind (ValBind entry name _ (Info (rettype, retext)) tparams params body _ attrs loc)+defuncValBind (ValBind entry name _ (Info (RetType _ rettype, retext)) tparams params body _ attrs loc)   | Scalar Arrow {} <- rettype = do     (body_pats, body', rettype') <- etaExpand (fromStruct rettype) body     defuncValBind $@@ -1239,13 +1272,13 @@         Nothing         attrs         loc-defuncValBind valbind@(ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ _ _) = do+defuncValBind valbind@(ValBind _ name retdecl (Info (RetType ret_dims rettype, retext)) tparams params body _ _ _) = do   when (any isTypeParam tparams) $     error $       prettyName name ++ " has type parameters, "         ++ "but the defunctionaliser expects a monomorphic input program."   (tparams', params', body', sv) <--    defuncLet (map typeParamName tparams) params body rettype+    defuncLet (map typeParamName tparams) params body $ RetType ret_dims rettype   globals <- asks fst   let bound_sizes = foldMap patNames params' <> S.fromList tparams' <> globals       rettype' =@@ -1255,15 +1288,18 @@         -- the types in the return type annotation.         combineTypeShapes rettype $ first (anyDimIfNotBound bound_sizes) $ toStruct $ typeOf body'   (missing_dims, params'') <- sizesForAll bound_sizes params'+   return     ( valbind         { valBindRetDecl = retdecl,           valBindRetType =             Info               ( if null params'-                  then rettype' `setUniqueness` Nonunique-                  else rettype',-                retext+                  then+                    ( RetType [] $ rettype' `setUniqueness` Nonunique,+                      retext+                    )+                  else (RetType ret_dims rettype', retext)               ),           valBindTypeParams =             map (`TypeParamDim` mempty) $ tparams' ++ missing_dims,

@@ -252,7 +252,9 @@           mapOnQualName = \v ->             return $ fst $ lookupSubstInScope v scope,           mapOnStructType = astMap (substituter scope),-          mapOnPatType = astMap (substituter scope)+          mapOnPatType = astMap (substituter scope),+          mapOnStructRetType = astMap (substituter scope),+          mapOnPatRetType = astMap (substituter scope)         }     onExp scope e =       -- One expression is tricky, because it interacts with scoping rules.@@ -274,25 +276,22 @@ transformExp = transformNames  transformValBind :: ValBind -> TransformM ()-transformValBind (ValBind entry name tdecl (Info (t, retext)) tparams params e doc attrs loc) = do+transformValBind (ValBind entry name tdecl (Info (RetType dims t, retext)) tparams params e doc attrs loc) = do   name' <- transformName name   tdecl' <- traverse transformTypeExp tdecl   t' <- transformStructType t   e' <- transformExp e   tparams' <- traverse transformNames tparams   params' <- traverse transformNames params-  emit $ ValDec $ ValBind entry name' tdecl' (Info (t', retext)) tparams' params' e' doc attrs loc--transformTypeDecl :: TypeDecl -> TransformM TypeDecl-transformTypeDecl (TypeDecl dt (Info et)) =-  TypeDecl <$> transformTypeExp dt <*> (Info <$> transformStructType et)+  emit $ ValDec $ ValBind entry name' tdecl' (Info (RetType dims t', retext)) tparams' params' e' doc attrs loc  transformTypeBind :: TypeBind -> TransformM ()-transformTypeBind (TypeBind name l tparams te doc loc) = do+transformTypeBind (TypeBind name l tparams te (Info (RetType dims t)) doc loc) = do   name' <- transformName name   emit . TypeDec     =<< ( TypeBind name' l <$> traverse transformNames tparams-            <*> transformTypeDecl te+            <*> transformTypeExp te+            <*> (Info . RetType dims <$> transformStructType t)             <*> pure doc             <*> pure loc         )

@@ -32,13 +32,6 @@     runInternaliseM always_safe (internaliseValBinds vbinds)   I.renameProg $ I.Prog consts funs -internaliseAttr :: E.AttrInfo -> Attr-internaliseAttr (E.AttrAtom v) = I.AttrAtom v-internaliseAttr (E.AttrComp f attrs) = I.AttrComp f $ map internaliseAttr attrs--internaliseAttrs :: [E.AttrInfo] -> Attrs-internaliseAttrs = mconcat . map (oneAttr . internaliseAttr)- internaliseValBinds :: [E.ValBind] -> InternaliseM () internaliseValBinds = mapM_ internaliseValBind @@ -71,10 +64,12 @@        let all_params = shapeparams ++ concat params' +      attrs' <- internaliseAttrs attrs+       let fd =             I.FunDef               Nothing-              (internaliseAttrs attrs)+              attrs'               (internaliseFunName fname)               rettype'               all_params@@ -116,18 +111,21 @@         Nothing ->           fst <$> funcall "entry_result" (E.qualName ofname) args loc       ctx <--        extractShapeContext (concat entry_rettype)+        extractShapeContext (zeroExts $ concat entry_rettype)           <$> mapM (fmap I.arrayDims . subExpType) vals       pure (subExpsRes $ ctx ++ vals, map (const (I.Prim int64)) ctx) +    attrs' <- internaliseAttrs attrs     addFunDef $       I.FunDef         (Just entry')-        (internaliseAttrs attrs)+        attrs'         ("entry_" <> baseName ofname)-        (ctx_ts ++ concat entry_rettype)+        (ctx_ts ++ zeroExts (concat entry_rettype))         (shapeparams ++ concat params')         entry_body+  where+    zeroExts ts = generaliseExtTypes ts ts  entryPoint ::   Name ->@@ -201,8 +199,27 @@   ((res, a), stms) <- collectStms m   (,a) <$> mkBodyM stms res -internaliseAppExp :: String -> E.AppExp -> InternaliseM [I.SubExp]-internaliseAppExp desc (E.Index e idxs loc) = do+-- | Only returns those pattern names that are not used in the pattern+-- itself (the "non-existential" part, you could say).+letValExp :: String -> I.Exp -> InternaliseM [VName]+letValExp name e = do+  e_t <- expExtType e+  names <- replicateM (length e_t) $ newVName name+  letBindNames names e+  let ctx = shapeContext e_t+  pure $ map fst $ filter ((`S.notMember` ctx) . snd) $ zip names [0 ..]++letValExp' :: String -> I.Exp -> InternaliseM [SubExp]+letValExp' _ (BasicOp (SubExp se)) = pure [se]+letValExp' name ses = map I.Var <$> letValExp name ses++eValBody :: [InternaliseM I.Exp] -> InternaliseM I.Body+eValBody es = buildBody_ $ do+  es' <- sequence es+  varsRes . concat <$> mapM (letValExp "x") es'++internaliseAppExp :: String -> [VName] -> E.AppExp -> InternaliseM [I.SubExp]+internaliseAppExp desc _ (E.Index e idxs loc) = do   vs <- internaliseExpToVars "indexed" e   dims <- case vs of     [] -> return [] -- Will this happen?@@ -212,7 +229,7 @@         v_t <- lookupType v         return $ I.BasicOp $ I.Index v $ fullSlice v_t idxs'   certifying cs $ letSubExps desc =<< mapM index vs-internaliseAppExp desc (E.Range start maybe_second end loc) = do+internaliseAppExp desc _ (E.Range start maybe_second end loc) = do   start' <- internaliseExp1 "range_start" start   end' <- internaliseExp1 "range_end" $ case end of     DownToExclusive e -> e@@ -350,9 +367,9 @@    se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it)   return [se]-internaliseAppExp desc (E.Coerce e (TypeDecl dt (Info et)) loc) = do+internaliseAppExp desc ext (E.Coerce e (TypeDecl dt (Info et)) loc) = do   ses <- internaliseExp desc e-  ts <- internaliseReturnType et =<< mapM subExpType ses+  ts <- internaliseReturnType (E.RetType ext et) =<< mapM subExpType ses   dt' <- typeExpForError dt   forM (zip ses ts) $ \(e', t') -> do     dims <- arrayDims <$> subExpType e'@@ -363,7 +380,7 @@             ++ dt'             ++ ["`."]     ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e'-internaliseAppExp desc e@E.Apply {} = do+internaliseAppExp desc _ e@E.Apply {} = do   (qfname, args) <- findFuncall e    -- Argument evaluation is outermost-in so that any existential sizes@@ -385,15 +402,15 @@         let tag ses = [(se, I.Observe) | se <- ses]         args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)         let args'' = concatMap tag args'-        letTupExp' desc $ I.Apply fname args'' [I.Prim rettype] (Safe, loc, [])+        letValExp' desc $ I.Apply fname args'' [I.Prim rettype] (Safe, loc, [])       | otherwise -> do         args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)         fst <$> funcall desc qfname args' loc-internaliseAppExp desc (E.LetPat sizes pat e body _) =+internaliseAppExp desc _ (E.LetPat sizes pat e body _) =   internalisePat desc sizes pat e body (internaliseExp desc)-internaliseAppExp _ (E.LetFun ofname _ _ _) =+internaliseAppExp _ _ (E.LetFun ofname _ _ _) =   error $ "Unexpected LetFun " ++ pretty ofname-internaliseAppExp desc (E.DoLoop sparams mergepat mergeexp form loopbody loc) = do+internaliseAppExp desc _ (E.DoLoop sparams mergepat mergeexp form loopbody loc) = do   ses <- internaliseExp "loop_init" mergeexp   ((loopbody', (form', shapepat, mergepat', mergeinit')), initstms) <-     collectStms $ handleForm ses form@@ -432,7 +449,7 @@   map I.Var . dropCond     <$> attributing       attrs-      (letTupExp desc (I.DoLoop (ctxmerge <> valmerge) form' loopbody''))+      (letValExp desc (I.DoLoop (ctxmerge <> valmerge) form' loopbody''))   where     sparams' = map (`TypeParamDim` mempty) sparams @@ -534,7 +551,7 @@                 loop_initial_cond : mergeinit               )             )-internaliseAppExp desc (E.LetWith name src idxs ve body loc) = do+internaliseAppExp desc _ (E.LetWith name src idxs ve body loc) = do   let pat = E.Id (E.identName name) (E.identType name) loc       src_t = E.fromStruct <$> E.identType src       e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc@@ -542,7 +559,7 @@     E.AppExp       (E.LetPat [] pat e body loc)       (Info (AppRes (E.typeOf body) mempty))-internaliseAppExp desc (E.Match e cs _) = do+internaliseAppExp desc _ (E.Match e cs _) = do   ses <- internaliseExp (desc ++ "_scrutinee") e   case NE.uncons cs of     (CasePat pCase eCase _, Nothing) -> do@@ -553,16 +570,16 @@       bFalse <- do         (_, pertinent) <- generateCond pLast ses         eLast' <- internalisePat' [] pLast pertinent eLast (internaliseBody desc)-        foldM (\bf c' -> eBody $ return $ generateCaseIf ses c' bf) eLast' $+        foldM (\bf c' -> eValBody $ return $ generateCaseIf ses c' bf) eLast' $           reverse $ NE.init cs'-      letTupExp' desc =<< generateCaseIf ses c bFalse-internaliseAppExp desc (E.If ce te fe _) =-  letTupExp' desc+      letValExp' desc =<< generateCaseIf ses c bFalse+internaliseAppExp desc _ (E.If ce te fe _) =+  letValExp' desc     =<< eIf       (BasicOp . SubExp <$> internaliseExp1 "cond" ce)       (internaliseBody (desc <> "_t") te)       (internaliseBody (desc <> "_f") fe)-internaliseAppExp _ e@E.BinOp {} =+internaliseAppExp _ _ e@E.BinOp {} =   error $ "internaliseAppExp: Unexpected BinOp " ++ pretty e  internaliseExp :: String -> E.Exp -> InternaliseM [I.SubExp]@@ -579,7 +596,7 @@     Just substs -> return substs     Nothing -> pure [I.Var name] internaliseExp desc (E.AppExp e (Info appres)) = do-  ses <- internaliseAppExp desc e+  ses <- internaliseAppExp desc (appResExt appres) e   bindExtSizes appres ses   pure ses @@ -722,11 +739,12 @@         return $ bef ++ src'' ++ aft     replace _ _ ve' _ = return ve' internaliseExp desc (E.Attr attr e loc) = do-  e' <- local f $ internaliseExp desc e+  attr' <- internaliseAttr attr+  e' <- local (f attr') $ internaliseExp desc e   case attr' of     "trace" ->       traceRes (locStr loc) e'-    I.AttrComp "trace" [I.AttrAtom tag] ->+    I.AttrComp "trace" [I.AttrName tag] ->       traceRes (nameToString tag) e'     "opaque" ->       mapM (letSubExp desc . BasicOp . Opaque OpaqueNil) e'@@ -735,8 +753,7 @@   where     traceRes tag' =       mapM (letSubExp desc . BasicOp . Opaque (OpaqueTrace tag'))-    attr' = internaliseAttr attr-    f env+    f attr' env       | attr' == "unsafe",         not $ envSafe env =         env {envDoBoundsChecks = False}@@ -869,6 +886,8 @@       return ([], id_ses, rest_ses)     compares (E.PatParens pat _) ses =       compares pat ses+    compares (E.PatAttr _ pat _) ses =+      compares pat ses     -- XXX: treat empty tuples and records as bool.     compares (E.TuplePat [] loc) ses =       compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses@@ -1109,7 +1128,7 @@   arrts <- mapM lookupType arrs   lam' <- internaliseFoldLambda internaliseLambda lam nests arrts   w <- arraysSize 0 <$> mapM lookupType arrs-  letTupExp' desc . I.Op =<< f w lam' nes' arrs+  letValExp' desc . I.Op =<< f w lam' nes' arrs  internaliseHist ::   String ->@@ -1178,7 +1197,7 @@       letExp (baseString buckets') $         I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets' -  letTupExp' desc . I.Op $+  letValExp' desc . I.Op $     I.Hist w_img [HistOp w_hist rf' hist' ne_shp op'] lam' $ buckets'' : img'  internaliseStreamMap ::@@ -1192,7 +1211,7 @@   lam' <- internaliseStreamMapLambda internaliseLambda lam $ map I.Var arrs   w <- arraysSize 0 <$> mapM lookupType arrs   let form = I.Parallel o Commutative (I.Lambda [] (mkBody mempty []) [])-  letTupExp' desc $ I.Op $ I.Stream w arrs form [] lam'+  letValExp' desc $ I.Op $ I.Stream w arrs form [] lam'  internaliseStreamRed ::   String ->@@ -1252,7 +1271,7 @@    let form = I.Parallel o comm lam0'   w <- arraysSize 0 <$> mapM lookupType arrs-  letTupExp' desc $ I.Op $ I.Stream w arrs form (map resSubExp nes) lam'+  letValExp' desc $ I.Op $ I.Stream w arrs form (map resSubExp nes) lam'  internaliseStreamAcc ::   String ->@@ -1270,12 +1289,12 @@   let dest_w = arraysSize 0 dest_ts       acc_t = Acc acc_cert_v (Shape [dest_w]) (map rowType dest_ts) NoUniqueness   acc_p <- newParam "acc_p" acc_t-  withacc_lam <- mkLambda [Param acc_cert_v (I.Prim I.Unit), acc_p] $ do+  withacc_lam <- mkLambda [Param mempty acc_cert_v (I.Prim I.Unit), acc_p] $ do     lam' <-       internaliseMapLambda internaliseLambda lam $         map I.Var $ paramName acc_p : bs'     w <- arraysSize 0 <$> mapM lookupType bs'-    fmap subExpsRes . letTupExp' "acc_res" $+    fmap subExpsRes . letValExp' "acc_res" $       I.Op $ I.Screma w (paramName acc_p : bs') (I.mapSOAC lam')    op' <-@@ -1529,7 +1548,7 @@ internaliseLambda :: InternaliseLambda internaliseLambda (E.Parens e _) rowtypes =   internaliseLambda e rowtypes-internaliseLambda (E.Lambda params body _ (Info (_, rettype)) _) rowtypes =+internaliseLambda (E.Lambda params body _ (Info (_, RetType _ rettype)) _) rowtypes =   bindingLambdaParams params rowtypes $ \params' -> do     body' <- internaliseBody "lam" body     rettype' <- internaliseLambdaReturnType rettype =<< bodyExtType body'@@ -1872,7 +1891,7 @@       let bodyTypes = concat (replicate (length sv_ts) indexType) ++ map (I.stripArray dim) sa_ts           paramTypes = indexType <> map rowType sv_ts           bodyNames = indexName <> valueNames-          bodyParams = zipWith I.Param bodyNames paramTypes+          bodyParams = zipWith (I.Param mempty) bodyNames paramTypes        -- This body is pretty boring right now, as every input is exactly the output.       -- But it can get funky later on if fused with something else.@@ -2035,9 +2054,8 @@       safety <- askSafety       attrs <- asks envAttrs       ses <--        attributing attrs $-          letTupExp' desc $-            I.Apply (internaliseFunName fname) (zip args' diets) ts (safety, loc, mempty)+        attributing attrs . letValExp' desc $+          I.Apply (internaliseFunName fname) (zip args' diets) ts (safety, loc, mempty)       return (ses, map I.fromDecl ts)  -- Bind existential names defined by an expression, based on the@@ -2075,9 +2093,9 @@     _ -> error "partitionWithSOACS"    add_lam_x_params <--    replicateM k $ I.Param <$> newVName "x" <*> pure (I.Prim int64)+    replicateM k $ newParam "x" (I.Prim int64)   add_lam_y_params <--    replicateM k $ I.Param <$> newVName "y" <*> pure (I.Prim int64)+    replicateM k $ newParam "y" (I.Prim int64)   add_lam_body <- runBodyBuilder $     localScope (scopeOfLParams $ add_lam_x_params ++ add_lam_y_params) $       fmap resultBody $@@ -2124,10 +2142,9 @@    -- Now write into the result.   write_lam <- do-    c_param <- I.Param <$> newVName "c" <*> pure (I.Prim int64)-    offset_params <- replicateM k $ I.Param <$> newVName "offset" <*> pure (I.Prim int64)-    value_params <- forM arr_ts $ \arr_t ->-      I.Param <$> newVName "v" <*> pure (I.rowType arr_t)+    c_param <- newParam "c" (I.Prim int64)+    offset_params <- replicateM k $ newParam "offset" (I.Prim int64)+    value_params <- mapM (newParam "v" . I.rowType) arr_ts     (offset, offset_stms) <-       collectStms $         mkOffsetLambdaBody@@ -2193,6 +2210,11 @@   return [ErrorString $ pretty qn] typeExpForError (E.TEUnique te _) =   ("*" :) <$> typeExpForError te+typeExpForError (E.TEDim dims te _) =+  (ErrorString ("?" <> dims' <> ".") :) <$> typeExpForError te+  where+    dims' = mconcat (map onDim dims)+    onDim d = "[" <> pretty d <> "]" typeExpForError (E.TEArray te d _) = do   d' <- dimExpForError d   te' <- typeExpForError te

@@ -82,9 +82,9 @@   AppExp (Apply e1 e2 _ _) _ -> freeVars e1 <> freeVars e2   Negate e _ -> freeVars e   Not e _ -> freeVars e-  Lambda pats e0 _ (Info (_, t)) _ ->+  Lambda pats e0 _ (Info (_, RetType dims t)) _ ->     (sizes (foldMap patternDimNames pats) <> freeVars e0 <> sizes (typeDimNames t))-      `withoutM` foldMap patVars pats+      `withoutM` (foldMap patVars pats <> foldMap size dims)   OpSection {} -> mempty   OpSectionLeft _ _ e _ _ _ -> freeVars e   OpSectionRight _ _ e _ _ _ -> freeVars e

@@ -42,7 +42,7 @@   InternaliseM I.Lambda internaliseStreamMapLambda internaliseLambda lam args = do   chunk_size <- newVName "chunk_size"-  let chunk_param = I.Param chunk_size (I.Prim int64)+  let chunk_param = I.Param mempty chunk_size (I.Prim int64)       outer = (`setOuterSize` I.Var chunk_size)   localScope (scopeOfLParams [chunk_param]) $ do     argtypes <- mapM I.subExpType args@@ -89,7 +89,7 @@   InternaliseM ([LParam], Body) internaliseStreamLambda internaliseLambda lam rowts = do   chunk_size <- newVName "chunk_size"-  let chunk_param = I.Param chunk_size $ I.Prim int64+  let chunk_param = I.Param mempty chunk_size $ I.Prim int64       chunktypes = map (`arrayOfRow` I.Var chunk_size) rowts   localScope (scopeOfLParams [chunk_param]) $ do     (lam_params, orig_body, _) <-@@ -97,8 +97,8 @@     let orig_chunk_param : params = lam_params     body <- runBodyBuilder $ do       letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size-      return orig_body-    return (chunk_param : params, body)+      pure orig_body+    pure (chunk_param : params, body)  -- Given @k@ lambdas, this will return a lambda that returns an -- (k+2)-element tuple of integers.  The first element is the@@ -132,7 +132,7 @@           BasicOp $             CmpOp (CmpEq int64) eq_class $               intConst Int64 $ toInteger i-      fmap (map I.Var) . letTupExp "part_res"+      letTupExp' "part_res"         =<< eIf           (eSubExp is_i)           (pure $ resultBody $ result i)

@@ -73,14 +73,15 @@       m = identityMapper {mapOnExp = \e' -> modify (<> existentials e') >> pure e'}    in execState (astMap m e) here -liftFunction :: VName -> [TypeParam] -> [Pat] -> StructType -> Exp -> LiftM Exp-liftFunction fname tparams params ret funbody = do+liftFunction :: VName -> [TypeParam] -> [Pat] -> StructRetType -> Exp -> LiftM Exp+liftFunction fname tparams params (RetType dims ret) funbody = do   -- Find free variables   global <- gets stateGlobal   let bound =         global           <> foldMap patNames params           <> S.fromList (map typeParamName tparams)+          <> S.fromList dims        free =         let immediate_free = FV.freeVars funbody `FV.without` (bound <> existentials funbody)@@ -110,7 +111,7 @@         valBindTypeParams = tparams,         valBindParams = free_params ++ params,         valBindRetDecl = Nothing,-        valBindRetType = Info (ret, mempty),+        valBindRetType = Info (RetType dims ret, mempty),         valBindBody = funbody,         valBindDoc = Nothing,         valBindAttrs = mempty,@@ -123,10 +124,10 @@       (Var (qualName fname) (Info (augType $ free_dims ++ free_nondims)) mempty)       $ free_dims ++ free_nondims   where-    orig_type = funType params ret+    orig_type = funType params $ RetType dims ret     mkParam (v, t) = Id v (Info (fromStruct t)) mempty     freeVar (v, t) = Var (qualName v) (Info (fromStruct t)) mempty-    augType rem_free = fromStruct $ funType (map mkParam rem_free) orig_type+    augType rem_free = fromStruct $ funType (map mkParam rem_free) $ RetType [] orig_type      apply :: Exp -> [(VName, StructType)] -> Exp     apply f [] = f

@@ -64,10 +64,10 @@       ( VName,         [TypeParam],         [Pat],-        StructType,+        StructRetType,         [VName],         Exp,-        [AttrInfo],+        [AttrInfo VName],         SrcLoc       ) @@ -147,7 +147,7 @@   = -- | The integer encodes an equivalence class, so we can keep     -- track of sizes that are statically identical.     MonoKnown Int-  | MonoAnon (Maybe VName)+  | MonoAnon VName   deriving (Show)  -- We treat all MonoAnon as identical.@@ -158,8 +158,7 @@  instance Pretty MonoSize where   ppr (MonoKnown i) = text "?" <> ppr i-  ppr (MonoAnon Nothing) = mempty-  ppr (MonoAnon (Just v)) = text "?" <> pprName v+  ppr (MonoAnon v) = text "?" <> pprName v  instance Pretty (ShapeDecl MonoSize) where   ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds)@@ -174,8 +173,7 @@   where     onDim bound _ (NamedDim d)       -- A locally bound size.-      | qualLeaf d `S.member` bound = pure $ MonoAnon $ Just $ qualLeaf d-    onDim _ _ (AnyDim v) = pure $ MonoAnon v+      | qualLeaf d `S.member` bound = pure $ MonoAnon $ qualLeaf d     onDim _ _ d = do       (i, m) <- get       case M.lookup d m of@@ -229,7 +227,7 @@       ( i -1,         AppExp           (Apply f size_arg (Info (Observe, Nothing)) loc)-          (Info $ AppRes (foldFunType (replicate i i64) (fromStruct t)) [])+          (Info $ AppRes (foldFunType (replicate i i64) (RetType [] (fromStruct t))) [])       )      applySizeArgs fname' t' size_args =@@ -242,7 +240,7 @@               ( Info                   ( foldFunType                       (map (const i64) size_args)-                      (fromStruct t')+                      (RetType [] $ fromStruct t')                   )               )               loc@@ -449,9 +447,8 @@   return $ Lambda params e0' decl tp loc transformExp (OpSection qn t loc) =   transformExp $ Var qn t loc-transformExp (OpSectionLeft fname (Info t) e arg ret loc) = do+transformExp (OpSectionLeft fname (Info t) e arg (Info rettype, Info retext) loc) = do   let (Info (xp, xtype, xargext), Info (yp, ytype)) = arg-      (Info rettype, Info retext) = ret   fname' <- transformFName loc fname $ toStruct t   e' <- transformExp e   desugarBinOpSection@@ -528,10 +525,10 @@   PatType ->   (PName, StructType, Maybe VName) ->   (PName, StructType, Maybe VName) ->-  (PatType, [VName]) ->+  (PatRetType, [VName]) ->   SrcLoc ->   MonoM Exp-desugarBinOpSection op e_left e_right t (xp, xtype, xext) (yp, ytype, yext) (rettype, retext) loc = do+desugarBinOpSection op e_left e_right t (xp, xtype, xext) (yp, ytype, yext) (RetType dims rettype, retext) loc = do   (v1, wrap_left, e1, p1) <- makeVarParam e_left $ fromStruct xtype   (v2, wrap_right, e2, p2) <- makeVarParam e_right $ fromStruct ytype   let apply_left =@@ -542,7 +539,7 @@               (Info (Observe, xext))               loc           )-          (Info $ AppRes (Scalar $ Arrow mempty yp (fromStruct ytype) t) [])+          (Info $ AppRes (Scalar $ Arrow mempty yp (fromStruct ytype) (RetType [] t)) [])       rettype' =         let onDim (NamedDim d)               | Named p <- xp, qualLeaf d == p = NamedDim $ qualName v1@@ -559,7 +556,10 @@           )           (Info $ AppRes rettype' retext)       rettype'' = toStruct rettype'-  return $ wrap_left $ wrap_right $ Lambda (p1 ++ p2) body Nothing (Info (mempty, rettype'')) loc+  return $+    wrap_left $+      wrap_right $+        Lambda (p1 ++ p2) body Nothing (Info (mempty, RetType dims rettype'')) loc   where     patAndVar argtype = do       x <- newNameFromString "x"@@ -579,10 +579,16 @@       return (v, id, var_e, [pat])  desugarProjectSection :: [Name] -> PatType -> SrcLoc -> MonoM Exp-desugarProjectSection fields (Scalar (Arrow _ _ t1 t2)) loc = do+desugarProjectSection fields (Scalar (Arrow _ _ t1 (RetType dims t2))) loc = do   p <- newVName "project_p"   let body = foldl project (Var (qualName p) (Info t1) mempty) fields-  return $ Lambda [Id p (Info t1) mempty] body Nothing (Info (mempty, toStruct t2)) loc+  return $+    Lambda+      [Id p (Info t1) mempty]+      body+      Nothing+      (Info (mempty, RetType dims $ toStruct t2))+      loc   where     project e field =       case typeOf e of@@ -597,10 +603,16 @@ desugarProjectSection _ t _ = error $ "desugarOpSection: not a function type: " ++ pretty t  desugarIndexSection :: [DimIndex] -> PatType -> SrcLoc -> MonoM Exp-desugarIndexSection idxs (Scalar (Arrow _ _ t1 t2)) loc = do+desugarIndexSection idxs (Scalar (Arrow _ _ t1 (RetType dims t2))) loc = do   p <- newVName "index_i"   let body = AppExp (Index (Var (qualName p) (Info t1) loc) idxs loc) (Info (AppRes t2 []))-  return $ Lambda [Id p (Info t1) mempty] body Nothing (Info (mempty, toStruct t2)) loc+  return $+    Lambda+      [Id p (Info t1) mempty]+      body+      Nothing+      (Info (mempty, RetType dims $ toStruct t2))+      loc desugarIndexSection _ t _ = error $ "desugarIndexSection: not a function type: " ++ pretty t  noticeDims :: TypeBase (DimDecl VName) as -> MonoM ()@@ -642,6 +654,9 @@ transformPat (PatParens pat loc) = do   (pat', rr) <- transformPat pat   return (PatParens pat' loc, rr)+transformPat (PatAttr attr pat loc) = do+  (pat', rr) <- transformPat pat+  return (PatAttr attr pat' loc, rr) transformPat (Wildcard (Info t) loc) = do   t' <- transformType t   return (wildcard t' loc, mempty)@@ -668,10 +683,12 @@   DimInst dimMapping t1 t2 = execState (matchDims f t1 t2) mempty   where-    f (NamedDim d1) d2 = do+    f bound d1 (NamedDim d2)+      | qualLeaf d2 `elem` bound = pure d1+    f _ (NamedDim d1) d2 = do       modify $ M.insert (qualLeaf d1) d2-      return $ NamedDim d1-    f d _ = return d+      pure $ NamedDim d1+    f _ d _ = pure d  inferSizeArgs :: [TypeParam] -> StructType -> StructType -> [Exp] inferSizeArgs tparams bind_t t =@@ -698,8 +715,8 @@   where     f (Array () u t shape) = Array () u (f' t) shape     f (Scalar t) = Scalar $ f' t-    f' (Arrow () _ t1 t2) =-      Arrow () Unnamed (f t1) (f t2)+    f' (Arrow () _ t1 (RetType dims t2)) =+      Arrow () Unnamed (f t1) (RetType dims (f t2))     f' (Record fs) =       Record $ fmap f fs     f' (Sum cs) =@@ -714,14 +731,14 @@   PolyBinding ->   MonoType ->   MonoM (VName, InferSizeArgs, ValBind)-monomorphiseBinding entry (PolyBinding rr (name, tparams, params, rettype, retext, body, attrs, loc)) t =+monomorphiseBinding entry (PolyBinding rr (name, tparams, params, rettype, retext, body, attrs, loc)) inst_t =   replaceRecordReplacements rr $ do     let bind_t = foldFunType (map patternStructType params) rettype-    (substs, t_shape_params) <- typeSubstsM loc (noSizes bind_t) $ noNamedParams t+    (substs, t_shape_params) <- typeSubstsM loc (noSizes bind_t) $ noNamedParams inst_t     let substs' = M.map (Subst []) substs-        rettype' = substTypesAny (`M.lookup` substs') rettype+        rettype' = applySubst (`M.lookup` substs') rettype         substPatType =-          substTypesAny (fmap (fmap fromStruct) . (`M.lookup` substs'))+          substTypesAny (fmap (fmap (second (const mempty))) . (`M.lookup` substs'))         params' = map (substPat entry substPatType) params         bind_t' = substTypesAny (`M.lookup` substs') bind_t         (shape_params_explicit, shape_params_implicit) =@@ -730,7 +747,7 @@      (params'', rrs) <- unzip <$> mapM transformPat params' -    mapM_ noticeDims $ rettype : map patternStructType params''+    mapM_ noticeDims $ retType rettype : map patternStructType params''      body' <- updateExpTypes (`M.lookup` substs') body     body'' <- withRecordReplacements (mconcat rrs) $ transformExp body'@@ -758,14 +775,17 @@   where     shape_params = filter (not . isTypeParam) tparams -    updateExpTypes substs = astMap $ mapper substs+    updateExpTypes substs e = astMap (mapper substs) e+     mapper substs =       ASTMapper-        { mapOnExp = astMap $ mapper substs,+        { mapOnExp = updateExpTypes substs,           mapOnName = pure,           mapOnQualName = pure,           mapOnStructType = pure . applySubst substs,-          mapOnPatType = pure . applySubst substs+          mapOnPatType = pure . applySubst substs,+          mapOnStructRetType = pure . applySubst substs,+          mapOnPatRetType = pure . applySubst substs         }      shapeParam tp = Id (typeParamName tp) (Info i64) $ srclocOf tp@@ -789,28 +809,32 @@   SrcLoc ->   TypeBase () () ->   MonoType ->-  m (M.Map VName StructType, [TypeParam])+  m (M.Map VName StructRetType, [TypeParam]) typeSubstsM loc orig_t1 orig_t2 =-  let m = sub orig_t1 orig_t2-   in runWriterT $ fst <$> execStateT m (mempty, mempty)+  runWriterT $ fst <$> execStateT (sub orig_t1 orig_t2) (mempty, mempty)   where+    subRet (Scalar (TypeVar _ _ v _)) rt =+      unless (baseTag (typeLeaf v) <= maxIntrinsicTag) $+        addSubst v rt+    subRet t1 (RetType _ t2) =+      sub t1 t2+     sub t1@Array {} t2@Array {}       | Just t1' <- peelArray (arrayRank t1) t1,         Just t2' <- peelArray (arrayRank t1) t2 =         sub t1' t2'     sub (Scalar (TypeVar _ _ v _)) t =-      -- Cannot substitute intrinsic abstract types.       unless (baseTag (typeLeaf v) <= maxIntrinsicTag) $-        addSubst v t+        addSubst v $ RetType [] t     sub (Scalar (Record fields1)) (Scalar (Record fields2)) =       zipWithM_         sub         (map snd $ sortFields fields1)         (map snd $ sortFields fields2)     sub (Scalar Prim {}) (Scalar Prim {}) = return ()-    sub (Scalar (Arrow _ _ t1a t1b)) (Scalar (Arrow _ _ t2a t2b)) = do+    sub (Scalar (Arrow _ _ t1a (RetType _ t1b))) (Scalar (Arrow _ _ t2a t2b)) = do       sub t1a t2a-      sub t1b t2b+      subRet t1b t2b     sub (Scalar (Sum cs1)) (Scalar (Sum cs2)) =       zipWithM_ typeSubstClause (sortConstrs cs1) (sortConstrs cs2)       where@@ -819,11 +843,11 @@     sub t1 t2@(Scalar Sum {}) = sub t1 t2     sub t1 t2 = error $ unlines ["typeSubstsM: mismatched types:", pretty t1, pretty t2] -    addSubst (TypeName _ v) t = do+    addSubst (TypeName _ v) (RetType ext t) = do       (ts, sizes) <- get       unless (v `M.member` ts) $ do         t' <- bitraverse onDim pure t-        put (M.insert v t' ts, sizes)+        put (M.insert v (RetType ext t') ts, sizes)      onDim (MonoKnown i) = do       (ts, sizes) <- get@@ -835,7 +859,7 @@           return $ NamedDim $ qualName d         Just d ->           return $ NamedDim $ qualName d-    onDim (MonoAnon v) = pure $ AnyDim v+    onDim (MonoAnon v) = pure $ AnyDim $ Just v  -- Perform a given substitution on the types in a pattern. substPat :: Bool -> (PatType -> PatType) -> Pat -> Pat@@ -845,6 +869,7 @@     where       substField (n, p) = (n, substPat entry f p)   PatParens p loc -> PatParens (substPat entry f p) loc+  PatAttr attr p loc -> PatAttr attr (substPat entry f p) loc   Id vn (Info tp) loc -> Id vn (Info $ f tp) loc   Wildcard (Info tp) loc -> Wildcard (Info $ f tp) loc   PatAscription p td loc@@ -859,22 +884,27 @@  -- Remove all type variables and type abbreviations from a value binding. removeTypeVariables :: Bool -> ValBind -> MonoM ValBind-removeTypeVariables entry valbind@(ValBind _ _ _ (Info (rettype, retext)) _ pats body _ _ _) = do+removeTypeVariables entry valbind = do+  let (ValBind _ _ _ (Info (RetType dims rettype, retext)) _ pats body _ _ _) = valbind   subs <- asks $ M.map substFromAbbr . envTypeBindings   let mapper =         ASTMapper-          { mapOnExp = astMap mapper,+          { mapOnExp = onExp,             mapOnName = pure,             mapOnQualName = pure,             mapOnStructType = pure . applySubst (`M.lookup` subs),-            mapOnPatType = pure . applySubst (`M.lookup` subs)+            mapOnPatType = pure . applySubst (`M.lookup` subs),+            mapOnStructRetType = pure . applySubst (`M.lookup` subs),+            mapOnPatRetType = pure . applySubst (`M.lookup` subs)           } -  body' <- astMap mapper body+      onExp e = astMap mapper e +  body' <- onExp body+   return     valbind-      { valBindRetType = Info (applySubst (`M.lookup` subs) rettype, retext),+      { valBindRetType = Info (applySubst (`M.lookup` subs) $ RetType dims rettype, retext),         valBindParams = map (substPat entry $ applySubst (`M.lookup` subs)) pats,         valBindBody = body'       }@@ -903,11 +933,10 @@   return mempty {envPolyBindings = M.singleton (valBindName valbind) valbind'}  transformTypeBind :: TypeBind -> MonoM Env-transformTypeBind (TypeBind name l tparams tydecl _ _) = do+transformTypeBind (TypeBind name l tparams _ (Info (RetType dims t)) _ _) = do   subs <- asks $ M.map substFromAbbr . envTypeBindings-  noticeDims $ unInfo $ expandedType tydecl-  let tp = applySubst (`M.lookup` subs) . unInfo $ expandedType tydecl-      tbinding = TypeAbbr l tparams tp+  noticeDims t+  let tbinding = TypeAbbr l tparams $ RetType dims $ applySubst (`M.lookup` subs) t   return mempty {envTypeBindings = M.singleton name tbinding}  transformDecs :: [Dec] -> MonoM ()

@@ -41,17 +41,17 @@ liftInternaliseM :: InternaliseM a -> InternaliseTypeM a liftInternaliseM = InternaliseTypeM . lift -runInternaliseTypeM ::-  InternaliseTypeM a ->-  InternaliseM a-runInternaliseTypeM (InternaliseTypeM m) =-  evalStateT m $ TypeState 0+runInternaliseTypeM :: InternaliseTypeM a -> InternaliseM a+runInternaliseTypeM = runInternaliseTypeM' mempty +runInternaliseTypeM' :: [VName] -> InternaliseTypeM a -> InternaliseM a+runInternaliseTypeM' exts (InternaliseTypeM m) = evalStateT m $ TypeState (length exts)+ internaliseParamTypes ::   [E.TypeBase (E.DimDecl VName) ()] ->   InternaliseM [[I.TypeBase Shape Uniqueness]] internaliseParamTypes ts =-  runInternaliseTypeM $ mapM (fmap (map onType) . internaliseTypeM) ts+  runInternaliseTypeM $ mapM (fmap (map onType) . internaliseTypeM mempty) ts   where     onType = fromMaybe bad . hasStaticShape     bad = error $ "internaliseParamTypes: " ++ pretty ts@@ -73,11 +73,13 @@   fixupTypes ts . concat <$> internaliseParamTypes [et]  internaliseReturnType ::-  E.TypeBase (E.DimDecl VName) () ->+  E.StructRetType ->   [TypeBase shape u] ->   InternaliseM [I.TypeBase ExtShape Uniqueness]-internaliseReturnType et ts =-  fixupTypes ts <$> runInternaliseTypeM (internaliseTypeM et)+internaliseReturnType (E.RetType dims et) ts =+  fixupTypes ts <$> runInternaliseTypeM' dims (internaliseTypeM exts et)+  where+    exts = M.fromList $ zip dims [0 ..]  internaliseLambdaReturnType ::   E.TypeBase (E.DimDecl VName) () ->@@ -89,18 +91,20 @@ -- | As 'internaliseReturnType', but returns components of a top-level -- tuple type piecemeal. internaliseEntryReturnType ::-  E.TypeBase (E.DimDecl VName) () ->+  E.StructRetType ->   InternaliseM [[I.TypeBase ExtShape Uniqueness]]-internaliseEntryReturnType et =-  runInternaliseTypeM . mapM internaliseTypeM $+internaliseEntryReturnType (E.RetType dims et) =+  runInternaliseTypeM' dims . mapM (internaliseTypeM exts) $     case E.isTupleRecord et of       Just ets | not $ null ets -> ets       _ -> [et]+  where+    exts = M.fromList $ zip dims [0 ..]  internaliseType ::   E.TypeBase (E.DimDecl VName) () ->   InternaliseM [I.TypeBase I.ExtShape Uniqueness]-internaliseType = runInternaliseTypeM . internaliseTypeM+internaliseType = runInternaliseTypeM . internaliseTypeM mempty  newId :: InternaliseTypeM Int newId = do@@ -109,28 +113,32 @@   return i  internaliseDim ::+  M.Map VName Int ->   E.DimDecl VName ->   InternaliseTypeM ExtSize-internaliseDim d =+internaliseDim exts d =   case d of     E.AnyDim _ -> Ext <$> newId     E.ConstDim n -> return $ Free $ intConst I.Int64 $ toInteger n     E.NamedDim name -> namedDim name   where-    namedDim (E.QualName _ name) = do-      subst <- liftInternaliseM $ lookupSubst name-      case subst of-        Just [v] -> return $ I.Free v-        _ -> return $ I.Free $ I.Var name+    namedDim (E.QualName _ name)+      | Just x <- name `M.lookup` exts = pure $ I.Ext x+      | otherwise = do+        subst <- liftInternaliseM $ lookupSubst name+        case subst of+          Just [v] -> pure $ I.Free v+          _ -> pure $ I.Free $ I.Var name  internaliseTypeM ::+  M.Map VName Int ->   E.StructType ->   InternaliseTypeM [I.TypeBase ExtShape Uniqueness]-internaliseTypeM orig_t =+internaliseTypeM exts orig_t =   case orig_t of     E.Array _ u et shape -> do       dims <- internaliseShape shape-      ets <- internaliseTypeM $ E.Scalar et+      ets <- internaliseTypeM exts $ E.Scalar et       return [I.arrayOf et' (Shape dims) $ internaliseUniqueness u | et' <- ets]     E.Scalar (E.Prim bt) ->       return [I.Prim $ internalisePrimType bt]@@ -139,11 +147,11 @@       -- arrays of unit will lose their sizes.       | null ets -> return [I.Prim I.Unit]       | otherwise ->-        concat <$> mapM (internaliseTypeM . snd) (E.sortFields ets)+        concat <$> mapM (internaliseTypeM exts . snd) (E.sortFields ets)     E.Scalar (E.TypeVar _ u tn [E.TypeArgType arr_t _])       | baseTag (E.typeLeaf tn) <= E.maxIntrinsicTag,         baseString (E.typeLeaf tn) == "acc" -> do-        ts <- map (fromDecl . onAccType) <$> internaliseTypeM arr_t+        ts <- map (fromDecl . onAccType) <$> internaliseTypeM exts arr_t         acc_param <- liftInternaliseM $ newVName "acc_cert"         let acc_t = Acc acc_param (Shape [arraysSize 0 ts]) (map rowType ts) $ internaliseUniqueness u         return [acc_t]@@ -154,10 +162,10 @@     E.Scalar (E.Sum cs) -> do       (ts, _) <-         internaliseConstructors-          <$> traverse (fmap concat . mapM internaliseTypeM) cs+          <$> traverse (fmap concat . mapM (internaliseTypeM exts)) cs       return $ I.Prim (I.IntType I.Int8) : ts   where-    internaliseShape = mapM internaliseDim . E.shapeDims+    internaliseShape = mapM (internaliseDim exts) . E.shapeDims      onAccType = fromMaybe bad . hasStaticShape     bad = error $ "internaliseTypeM Acc: " ++ pretty orig_t@@ -196,7 +204,7 @@ internaliseSumType cs =   runInternaliseTypeM $     internaliseConstructors-      <$> traverse (fmap concat . mapM internaliseTypeM) cs+      <$> traverse (fmap concat . mapM (internaliseTypeM mempty)) cs  -- | How many core language values are needed to represent one source -- language value of the given type?

@@ -123,7 +123,7 @@   m (Param dec) newParam s t = do   s' <- newID $ nameFromString s-  return $ Param s' t+  return $ Param mempty s' t  -- Utility instance defintions for MTL classes.  This requires -- UndecidableInstances, but saves on typing elsewhere.

@@ -256,7 +256,7 @@   pure (outer_stms_1 <> outer_stms_2, pat'', merge'', body'')  isArrayIn :: VName -> Param FParamMem -> Bool-isArrayIn x (Param _ (MemArray _ _ _ (ArrayIn y _))) = x == y+isArrayIn x (Param _ _ (MemArray _ _ _ (ArrayIn y _))) = x == y isArrayIn _ _ = False  optimiseLoopBySwitching :: Constraints rep inner => OptimiseLoop rep@@ -288,9 +288,7 @@             <$> newVName (baseString (patElemName pe) <> "_unused")             <*> pure (MemMem space)         param_out <--          Param-            <$> newVName (baseString (paramName param) <> "_out")-            <*> pure (MemMem space)+          newParam (baseString (paramName param) <> "_out") (MemMem space)         addStm res_v_alloc         pure           ( ( M.insert (paramName param) arr_mem_in buffered,@@ -309,7 +307,7 @@             ([pe], [(param, arg)], [res])           ) -    maybeCopyInitial buffered (param@(Param _ (MemArray _ _ _ (ArrayIn mem _))), Var arg)+    maybeCopyInitial buffered (param@(Param _ _ (MemArray _ _ _ (ArrayIn mem _))), Var arg)       | Just mem' <- mem `M.lookup` buffered = do         arg_info <- lookupMemInfo arg         case arg_info of@@ -414,14 +412,14 @@   DoubleBufferM rep ([(FParam rep, SubExp)], [Stm rep]) allocStms merge = runWriterT . zipWithM allocation merge   where-    allocation m@(Param pname _, _) (BufferAlloc name size space b) = do+    allocation m@(Param attrs pname _, _) (BufferAlloc name size space b) = do       stms <- lift $         runBuilder_ $ do           size' <- toSubExp "double_buffer_size" size           letBindNames [name] $ Op $ Alloc size' space       tell $ stmsToList stms       if b-        then pure (Param pname $ MemMem space, Var name)+        then pure (Param attrs pname $ MemMem space, Var name)         else pure m     allocation (f, Var v) (BufferCopy mem _ _ b) | b = do       v_copy <- lift $ newVName $ baseString v ++ "_double_buffer_copy"@@ -429,10 +427,7 @@       let bt = elemType $ paramType f           shape = arrayShape $ paramType f           bound = MemArray bt shape NoUniqueness $ ArrayIn mem v_ixfun-      tell-        [ Let (Pat [PatElem v_copy bound]) (defAux ()) $-            BasicOp $ Copy v-        ]+      tell [Let (Pat [PatElem v_copy bound]) (defAux ()) $ BasicOp $ Copy v]       -- It is important that we treat this as a consumption, to       -- avoid the Copy from being hoisted out of any enclosing       -- loops.  Since we re-use (=overwrite) memory in the loop,

@@ -686,18 +686,18 @@     | not $ null loop_vars = do       let (merge_params, merge_init) = unzip merge           (loop_params, loop_arrs) = unzip loop_vars-      chunk_size <- newVName "chunk_size"-      offset <- newVName "offset"-      let chunk_param = Param chunk_size $ Prim int64-          offset_param = Param offset $ Prim $ IntType it+      chunk_param <- newParam "chunk_size" $ Prim int64+      offset_param <- newParam "offset" $ Prim $ IntType it+      let offset = paramName offset_param+          chunk_size = paramName chunk_param        acc_params <- forM merge_params $ \p ->-        Param <$> newVName (baseString (paramName p) ++ "_outer")-          <*> pure (paramType p)+        newParam (baseString (paramName p) ++ "_outer") (paramType p)        chunked_params <- forM loop_vars $ \(p, arr) ->-        Param <$> newVName (baseString arr ++ "_chunk")-          <*> pure (paramType p `arrayOfRow` Futhark.Var chunk_size)+        newParam+          (baseString arr ++ "_chunk")+          (paramType p `arrayOfRow` Futhark.Var chunk_size)        let lam_params = chunk_param : acc_params ++ [offset_param] ++ chunked_params 

@@ -69,7 +69,7 @@     lam2' =       lam2         { lambdaParams =-            [ Param name t+            [ Param mempty name t               | Ident name t <- lam2redparams ++ M.keys inputmap             ],           lambdaBody = new_body2'

@@ -269,9 +269,7 @@           )         return $           Right-            ( Param-                mergename-                (toDecl (typeOf mergedec) Unique),+            ( Param mempty mergename (toDecl (typeOf mergedec) Unique),               Var source             )       | otherwise = return $ Left $ mergeParam summary

@@ -233,6 +233,9 @@           zip (map resSubExp (bodyResult tbranch)) (map resSubExp (bodyResult fbranch)) ruleBasicOp _ pat _ (Replicate (Shape []) se@Constant {}) =   Simplify $ letBind pat $ BasicOp $ SubExp se+ruleBasicOp _ pat _ (Replicate _ se)+  | [Acc {}] <- patTypes pat =+    Simplify $ letBind pat $ BasicOp $ SubExp se ruleBasicOp _ pat _ (Replicate (Shape []) (Var v)) = Simplify $ do   v_t <- lookupType v   letBind pat $

@@ -379,8 +379,8 @@           inScopeOf precomputed_variant_prestms $             doPrelude tiling privstms precomputed_variant_prestms live_set -        mergeparams' <- forM mergeparams $ \(Param pname pt) ->-          Param <$> newVName (baseString pname ++ "_group") <*> pure (tileDim pt)+        mergeparams' <- forM mergeparams $ \(Param attrs pname pt) ->+          Param attrs <$> newVName (baseString pname ++ "_group") <*> pure (tileDim pt)          let merge_ts = map paramType mergeparams 

@@ -814,7 +814,7 @@             BinOp (SMax Int64) (Var $ paramName x) (Var $ paramName y)     return $ Lambda (xs ++ ys) (mkBody stms zs) i64s -  flat_gtid_lparam <- Param <$> newVName "flat_gtid" <*> pure (Prim (IntType Int64))+  flat_gtid_lparam <- newParam "flat_gtid" (Prim (IntType Int64))    (size_lam', _) <- flip runBuilderT kernels_scope $ do     params <- replicateM num_sizes $ newParam "x" (Prim int64)

@@ -358,7 +358,7 @@       let memname = baseString (paramName param) <> "_mem"           ixfun = IxFun.iota $ map pe64 $ shapeDims shape       mem <- lift $ newVName memname-      tell ([], [Param mem $ MemMem pspace])+      tell ([], [Param (paramAttrs param) mem $ MemMem pspace])       return param {paramDec = MemArray pt shape u $ ArrayIn mem ixfun}     Prim pt ->       return param {paramDec = MemPrim pt}@@ -437,11 +437,11 @@                 (_, v') <- lift $ allocLinearArray DefaultSpace (baseString v) v                 allocInMergeParam (mergeparam, Var v')               else do-                mem_name <- newVName "mem_param"-                tell ([], [Param mem_name $ MemMem v_mem_space])+                p <- newParam "mem_param" $ MemMem v_mem_space+                tell ([], [p])                  pure-                  ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn mem_name v_ixfun},+                  ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn (paramName p) v_ixfun},                     Var v,                     scalarRes param_t v_mem_space v_ixfun                   )@@ -452,11 +452,8 @@              (ctx_params, param_ixfun_substs) <-               fmap unzip . forM substs $ \e -> do-                vname <- lift $ newVName "ctx_param_ext"-                pure-                  ( Param vname $ MemPrim $ primExpType $ untyped e,-                    fmap Free $ pe64 $ Var vname-                  )+                p <- newParam "ctx_param_ext" $ MemPrim $ primExpType $ untyped e+                pure (p, fmap Free $ le64 $ paramName p)              tell (ctx_params, []) @@ -466,11 +463,10 @@                   (M.fromList $ zip (fmap Ext [0 ..]) param_ixfun_substs)                   ext_ixfun -            mem_name <- newVName "mem_param"-            tell ([], [Param mem_name $ MemMem v_mem_space'])-+            mem_param <- newParam "mem_param" $ MemMem v_mem_space'+            tell ([], [mem_param])             pure-              ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn mem_name param_ixfun},+              ( mergeparam {paramDec = MemArray pt shape u $ ArrayIn (paramName mem_param) param_ixfun},                 v',                 ensureArrayIn v_mem_space'               )@@ -828,11 +824,11 @@   WithAcc <$> mapM onInput inputs <*> onLambda bodylam   where     onLambda lam = do-      params <- forM (lambdaParams lam) $ \(Param pv t) ->+      params <- forM (lambdaParams lam) $ \(Param attrs pv t) ->         case t of-          Prim Unit -> pure $ Param pv $ MemPrim Unit-          Acc acc ispace ts u -> pure $ Param pv $ MemAcc acc ispace ts u-          _ -> error $ "Unexpected WithAcc lambda param: " ++ pretty (Param pv t)+          Prim Unit -> pure $ Param attrs pv $ MemPrim Unit+          Acc acc ispace ts u -> pure $ Param attrs pv $ MemAcc acc ispace ts u+          _ -> error $ "Unexpected WithAcc lambda param: " ++ pretty (Param attrs pv t)       allocInLambda params (lambdaBody lam)      onInput (shape, arrs, op) =@@ -843,7 +839,7 @@           num_is = shapeRank accshape           (i_params, x_params, y_params) =             splitAt3 num_is num_vs $ lambdaParams lam-          i_params' = map ((`Param` MemPrim int64) . paramName) i_params+          i_params' = map (\(Param attrs v _) -> Param attrs v $ MemPrim int64) i_params           is = map (DimFix . Var . paramName) i_params'       x_params' <- zipWithM (onXParam is) x_params arrs       y_params' <- zipWithM (onYParam is) y_params arrs@@ -853,26 +849,26 @@           (lambdaBody lam)       return (lam', nes) -    mkP p pt shape u mem ixfun is =-      Param p . MemArray pt shape u . ArrayIn mem . IxFun.slice ixfun $+    mkP attrs p pt shape u mem ixfun is =+      Param attrs p . MemArray pt shape u . ArrayIn mem . IxFun.slice ixfun $         fmap pe64 $ Slice $ is ++ map sliceDim (shapeDims shape) -    onXParam _ (Param p (Prim t)) _ =-      return $ Param p (MemPrim t)-    onXParam is (Param p (Array pt shape u)) arr = do+    onXParam _ (Param attrs p (Prim t)) _ =+      pure $ Param attrs p (MemPrim t)+    onXParam is (Param attrs p (Array pt shape u)) arr = do       (mem, ixfun) <- lookupArraySummary arr-      return $ mkP p pt shape u mem ixfun is+      pure $ mkP attrs p pt shape u mem ixfun is     onXParam _ p _ =       error $ "Cannot handle MkAcc param: " ++ pretty p -    onYParam _ (Param p (Prim t)) _ =-      return $ Param p (MemPrim t)-    onYParam is (Param p (Array pt shape u)) arr = do+    onYParam _ (Param attrs p (Prim t)) _ =+      pure $ Param attrs p $ MemPrim t+    onYParam is (Param attrs p (Array pt shape u)) arr = do       arr_t <- lookupType arr       mem <- allocForArray arr_t DefaultSpace       let base_dims = map pe64 $ arrayDims arr_t           ixfun = IxFun.iota base_dims-      pure $ mkP p pt shape u mem ixfun is+      pure $ mkP attrs p pt shape u mem ixfun is     onYParam _ p _ =       error $ "Cannot handle MkAcc param: " ++ pretty p allocInExp e = mapExpM alloc e

@@ -294,7 +294,7 @@   i <- newVName "gtid"   let inps =         [ KernelInput pname ptype arr [Var i]-          | (Param pname ptype, arr) <- params_and_arrs+          | (Param _ pname ptype, arr) <- params_and_arrs         ]   return ([(i, nesting_w)], inps) flatKernel (MapNesting _ _ nesting_w params_and_arrs, nest : nests) = do@@ -317,7 +317,7 @@   where     extra_inps i =       [ KernelInput pname ptype arr [Var i]-        | (Param pname ptype, arr) <- params_and_arrs+        | (Param _ pname ptype, arr) <- params_and_arrs       ]  -- | Description of distribution to do.@@ -421,13 +421,13 @@                       newIdent (baseString pname ++ "_r") $                         arrayOfRow ptype w                     return-                      ( Param pname ptype,+                      ( Param mempty pname ptype,                         arr,                         True                       )                   Just arr ->                     return-                      ( Param pname ptype,+                      ( Param mempty pname ptype,                         arr,                         False                       )

@@ -56,7 +56,7 @@     let loop_pat_expanded =           Pat $ map expandPatElem $ patElems loop_pat         new_params =-          [Param pname $ fromDecl ptype | (Param pname ptype, _) <- merge]+          [Param attrs pname $ fromDecl ptype | (Param attrs pname ptype, _) <- merge]         new_arrs = map (paramName . fst) merge_expanded         rettype = map rowType $ patTypes loop_pat_expanded @@ -210,8 +210,8 @@       newAccLamParams ps = do         let (cert_ps, acc_ps) = splitAt (length ps `div` 2) ps         -- Should not rename the certificates.-        acc_ps' <- forM acc_ps $ \(Param v t) ->-          newParam (baseString v) t+        acc_ps' <- forM acc_ps $ \(Param attrs v t) ->+          Param attrs <$> newVName (baseString v) <*> pure t         pure $ cert_ps <> acc_ps'        num_accs = length inputs

@@ -175,9 +175,8 @@   Lambda GPU ->   m (Lambda GPU) kerneliseLambda nes lam = do-  thread_index <- newVName "thread_index"-  let thread_index_param = Param thread_index $ Prim int64-      (fold_chunk_param, fold_acc_params, fold_inp_params) =+  thread_index_param <- newParam "thread_index" $ Prim int64+  let (fold_chunk_param, fold_acc_params, fold_inp_params) =         partitionChunkedFoldParameters (length nes) $ lambdaParams lam        mkAccInit p (Var v)

@@ -50,7 +50,7 @@   addLog _ = pure ()  indexArray :: VName -> LParam SOACS -> VName -> Stm MC-indexArray i (Param p t) arr =+indexArray i (Param _ p t) arr =   Let (Pat [PatElem p t]) (defAux ()) . BasicOp $     case t of       Acc {} -> SubExp $ Var arr@@ -164,7 +164,7 @@   let (chunk_param, acc_params, slice_params) =         partitionChunkedFoldParameters (length nes) (lambdaParams lam) -  inp_params <- forM slice_params $ \(Param p t) ->+  inp_params <- forM slice_params $ \(Param _ p t) ->     newParam (baseString p) (rowType t)    body <- runBodyBuilder $

@@ -15,6 +15,7 @@     Func (..),     Exp (..),     parseExp,+    parseExpFromText,     varsInExp,     ScriptValueType (..),     ScriptValue (..),@@ -49,8 +50,9 @@ import Futhark.Server.Values (getValue, putValue) import qualified Futhark.Test.Values as V import Futhark.Util (nubOrd)-import Futhark.Util.Pretty hiding (float, line, sep, string, (</>), (<|>))+import Futhark.Util.Pretty hiding (float, line, sep, space, string, (</>), (<|>)) import Text.Megaparsec+import Text.Megaparsec.Char (space) import Text.Megaparsec.Char.Lexer (charLiteral)  -- | Like a 'Server', but keeps a bit more state to make FutharkScript@@ -126,7 +128,7 @@ inBraces :: Parser () -> Parser a -> Parser a inBraces sep = between (lexeme sep "{") (lexeme sep "}") --- | Parse a FutharkScript expression.+-- | Parse a FutharkScript expression, given a whitespace parser. parseExp :: Parser () -> Parser Exp parseExp sep =   choice@@ -175,6 +177,11 @@       pure v       where         constituent c = isAlphaNum c || c == '_'++-- | Parse a FutharkScript expression with normal whitespace handling.+parseExpFromText :: FilePath -> T.Text -> Either T.Text Exp+parseExpFromText f s =+  either (Left . T.pack . errorBundlePretty) Right $ parse (parseExp space) f s  readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value readVar server v =

@@ -6,10 +6,7 @@ -- program is an ordinary Futhark program where an initial comment -- block specifies input- and output-sets. module Futhark.Test-  ( testSpecFromFile,-    testSpecFromFileOrDie,-    testSpecsFromPaths,-    testSpecsFromPathsOrDie,+  ( module Futhark.Test.Spec,     valuesFromByteString,     FutharkExe (..),     getValues,@@ -27,17 +24,6 @@     binaryName,     futharkServerCfg,     V.Mismatch,-    ProgramTest (..),-    StructureTest (..),-    StructurePipeline (..),-    WarningTest (..),-    TestAction (..),-    ExpectedError (..),-    InputOutputs (..),-    TestRun (..),-    ExpectedResult (..),-    Success (..),-    Values (..),     V.Value,     V.valueText,   )@@ -54,23 +40,17 @@ import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as BS import Data.Char-import Data.Functor-import Data.List (foldl')-import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T-import Data.Void-import Futhark.Analysis.Metrics.Type-import Futhark.Data.Parser-import qualified Futhark.Data.Parser as V import qualified Futhark.Script as Script import Futhark.Server import Futhark.Server.Values+import Futhark.Test.Spec import qualified Futhark.Test.Values as V-import Futhark.Util (directoryContents, isEnvVarAtLeast, pmapIO)+import Futhark.Util (isEnvVarAtLeast, pmapIO) import Futhark.Util.Pretty (prettyOneLine, prettyText, prettyTextOneLine) import System.Directory import System.Exit@@ -79,407 +59,8 @@ import System.IO.Error import System.IO.Temp import System.Process.ByteString (readProcessWithExitCode)-import Text.Megaparsec hiding (many, some)-import Text.Megaparsec.Char-import Text.Regex.TDFA import Prelude --- | 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-  }-  deriving (Show)---- | How to test a program.-data TestAction-  = CompileTimeFailure ExpectedError-  | RunCases [InputOutputs] [StructureTest] [WarningTest]-  deriving (Show)---- | Input and output pairs for some entry point(s).-data InputOutputs = InputOutputs-  { iosEntryPoint :: T.Text,-    iosTestRuns :: [TestRun]-  }-  deriving (Show)---- | The error expected for a negative test.-data ExpectedError-  = AnyError-  | ThisError T.Text Regex--instance Show ExpectedError where-  show AnyError = "AnyError"-  show (ThisError r _) = "ThisError " ++ show r---- | How a program can be transformed.-data StructurePipeline-  = KernelsPipeline-  | SOACSPipeline-  | SequentialCpuPipeline-  | GpuPipeline-  | NoPipeline-  deriving (Show)---- | A structure test specifies a compilation pipeline, as well as--- metrics for the program coming out the other end.-data StructureTest = StructureTest StructurePipeline AstMetrics-  deriving (Show)---- | A warning test requires that a warning matching the regular--- expression is produced.  The program must also compile succesfully.-data WarningTest = ExpectedWarning T.Text Regex--instance Show WarningTest where-  show (ExpectedWarning r _) = "ExpectedWarning " ++ T.unpack r---- | A condition for execution, input, and expected result.-data TestRun = TestRun-  { runTags :: [String],-    runInput :: Values,-    runExpectedResult :: ExpectedResult Success,-    runIndex :: Int,-    runDescription :: String-  }-  deriving (Show)---- | Several values - either literally, or by reference to a file, or--- to be generated on demand.  All paths are relative to test program.-data Values-  = Values [V.Value]-  | InFile FilePath-  | GenValues [GenValue]-  | ScriptValues Script.Exp-  | ScriptFile FilePath-  deriving (Show)--data GenValue-  = -- | Generate a value of the given rank and primitive-    -- type.  Scalars are considered 0-ary arrays.-    GenValue V.ValueType-  | -- | A fixed non-randomised primitive value.-    GenPrim V.Value-  deriving (Show)---- | A prettyprinted representation of type of value produced by a--- 'GenValue'.-genValueType :: GenValue -> String-genValueType (GenValue (V.ValueType ds t)) =-  concatMap (\d -> "[" ++ show d ++ "]") ds ++ T.unpack (V.primTypeText t)-genValueType (GenPrim v) =-  T.unpack $ V.valueText v---- | How a test case is expected to terminate.-data ExpectedResult values-  = -- | Execution suceeds, with or without-    -- expected result values.-    Succeeds (Maybe values)-  | -- | Execution fails with this error.-    RunTimeFailure ExpectedError-  deriving (Show)---- | The result expected from a succesful execution.-data Success-  = -- | These values are expected.-    SuccessValues Values-  | -- | Compute expected values from executing a known-good-    -- reference implementation.-    SuccessGenerateValues-  deriving (Show)--type Parser = Parsec Void T.Text--postlexeme :: Parser ()-postlexeme = void $ hspace *> optional (try $ eol *> "--" *> postlexeme)--lexeme :: Parser a -> Parser a-lexeme p = p <* postlexeme---- Like 'lexeme', but does not consume trailing linebreaks.-lexeme' :: Parser a -> Parser a-lexeme' p = p <* hspace--lexstr :: T.Text -> Parser ()-lexstr = void . try . lexeme . string---- Like 'lexstr', but does not consume trailing linebreaks.-lexstr' :: T.Text -> Parser ()-lexstr' = void . try . lexeme' . string--braces :: Parser a -> Parser a-braces p = lexstr "{" *> p <* lexstr "}"--parseNatural :: Parser Int-parseNatural =-  lexeme $-    foldl' (\acc x -> acc * 10 + x) 0-      . map num-      <$> some digitChar-  where-    num c = ord c - ord '0'--restOfLine :: Parser T.Text-restOfLine = do-  l <- restOfLine_-  if T.null l then void eol else void eol <|> eof-  pure l--restOfLine_ :: Parser T.Text-restOfLine_ = takeWhileP Nothing (/= '\n')--parseDescription :: Parser T.Text-parseDescription =-  T.unlines <$> pDescLine `manyTill` pDescriptionSeparator-  where-    pDescLine = "--" *> restOfLine-    pDescriptionSeparator = void $ "-- ==" *> postlexeme--parseTags :: Parser [T.Text]-parseTags = lexeme' "tags" *> braces (many parseTag) <|> pure []-  where-    parseTag = T.pack <$> lexeme (some $ satisfy tagConstituent)--tagConstituent :: Char -> Bool-tagConstituent c = isAlphaNum c || c == '_' || c == '-'--parseAction :: Parser TestAction-parseAction =-  CompileTimeFailure <$> (lexstr' "error:" *> parseExpectedError)-    <|> ( RunCases <$> parseInputOutputs-            <*> many parseExpectedStructure-            <*> many parseWarning-        )--parseInputOutputs :: Parser [InputOutputs]-parseInputOutputs = do-  entrys <- parseEntryPoints-  cases <- parseRunCases-  return $-    if null cases-      then []-      else map (`InputOutputs` cases) entrys--parseEntryPoints :: Parser [T.Text]-parseEntryPoints =-  (lexeme' "entry:" *> many entry <* postlexeme)-    <|> pure ["main"]-  where-    constituent c = not (isSpace c) && c /= '}'-    entry = lexeme' $ T.pack <$> some (satisfy constituent)--parseRunTags :: Parser [String]-parseRunTags = many . try . lexeme' $ do-  s <- some $ satisfy tagConstituent-  guard $ s `notElem` ["input", "structure", "warning"]-  return s--parseRunCases :: Parser [TestRun]-parseRunCases = parseRunCases' (0 :: Int)-  where-    parseRunCases' i =-      (:) <$> parseRunCase i <*> parseRunCases' (i + 1)-        <|> pure []-    parseRunCase i = do-      tags <- parseRunTags-      lexstr "input"-      input <--        if "random" `elem` tags-          then parseRandomValues-          else-            if "script" `elem` tags-              then parseScriptValues-              else parseValues-      expr <- parseExpectedResult-      return $ TestRun tags input expr i $ desc i input--    -- If the file is gzipped, we strip the 'gz' extension from-    -- the dataset name.  This makes it more convenient to rename-    -- from 'foo.in' to 'foo.in.gz', as the reported dataset name-    -- does not change (which would make comparisons to historical-    -- data harder).-    desc _ (InFile path)-      | takeExtension path == ".gz" = dropExtension path-      | otherwise = path-    desc i (Values vs) =-      -- Turn linebreaks into space.-      "#" ++ show i ++ " (\"" ++ unwords (lines vs') ++ "\")"-      where-        vs' = case unwords $ map (T.unpack . V.valueText) vs of-          s-            | length s > 50 -> take 50 s ++ "..."-            | otherwise -> s-    desc _ (GenValues gens) =-      unwords $ map genValueType gens-    desc _ (ScriptValues e) =-      prettyOneLine e-    desc _ (ScriptFile path) =-      path--parseExpectedResult :: Parser (ExpectedResult Success)-parseExpectedResult =-  (lexstr "auto" *> lexstr "output" $> Succeeds (Just SuccessGenerateValues))-    <|> (Succeeds . Just . SuccessValues <$> (lexstr "output" *> parseValues))-    <|> (RunTimeFailure <$> (lexstr "error:" *> parseExpectedError))-    <|> pure (Succeeds Nothing)--parseExpectedError :: Parser ExpectedError-parseExpectedError = lexeme $ do-  s <- T.strip <$> restOfLine_ <* postlexeme-  if T.null s-    then return AnyError-    else -- blankCompOpt creates a regular expression that treats-    -- newlines like ordinary characters, which is what we want.-      ThisError s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s)--parseScriptValues :: Parser Values-parseScriptValues =-  choice-    [ ScriptValues <$> braces (Script.parseExp postlexeme),-      ScriptFile . T.unpack <$> (lexstr "@" *> lexeme nextWord)-    ]-  where-    nextWord = takeWhileP Nothing $ not . isSpace--parseRandomValues :: Parser Values-parseRandomValues = GenValues <$> braces (many parseGenValue)--parseGenValue :: Parser GenValue-parseGenValue =-  choice-    [ GenValue <$> lexeme parseType,-      GenPrim <$> lexeme V.parsePrimValue-    ]--parseValues :: Parser Values-parseValues =-  choice-    [ Values <$> braces (many $ parseValue postlexeme),-      InFile . T.unpack <$> (lexstr "@" *> lexeme nextWord)-    ]-  where-    nextWord = takeWhileP Nothing $ not . isSpace--parseWarning :: Parser WarningTest-parseWarning = lexstr "warning:" >> parseExpectedWarning-  where-    parseExpectedWarning = lexeme $ do-      s <- T.strip <$> restOfLine_-      ExpectedWarning s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s)--parseExpectedStructure :: Parser StructureTest-parseExpectedStructure =-  lexstr "structure"-    *> (StructureTest <$> optimisePipeline <*> parseMetrics)--optimisePipeline :: Parser StructurePipeline-optimisePipeline =-  lexstr "distributed" $> KernelsPipeline-    <|> lexstr "gpu" $> GpuPipeline-    <|> lexstr "cpu" $> SequentialCpuPipeline-    <|> lexstr "internalised" $> NoPipeline-    <|> pure SOACSPipeline--parseMetrics :: Parser AstMetrics-parseMetrics =-  braces $-    fmap (AstMetrics . M.fromList) $-      many $-        (,) <$> (T.pack <$> lexeme (some (satisfy constituent))) <*> parseNatural-  where-    constituent c = isAlpha c || c == '/'--testSpec :: Parser ProgramTest-testSpec =-  ProgramTest <$> parseDescription <*> parseTags <*> parseAction--couldNotRead :: IOError -> IO (Either String a)-couldNotRead = return . Left . show--pProgramTest :: Parser ProgramTest-pProgramTest = do-  void $ many pNonTestLine-  maybe_spec <- optional testSpec <* pEndOfTestBlock <* many pNonTestLine-  case maybe_spec of-    Just spec-      | RunCases old_cases structures warnings <- testAction spec -> do-        cases <- many $ pInputOutputs <* many pNonTestLine-        pure spec {testAction = RunCases (old_cases ++ concat cases) structures warnings}-      | otherwise ->-        many pNonTestLine *> notFollowedBy "-- ==" *> pure spec-          <?> "no more test blocks, since first test block specifies type error."-    Nothing ->-      eof $> noTest-  where-    noTest =-      ProgramTest mempty mempty (RunCases mempty mempty mempty)--    pEndOfTestBlock =-      (void eol <|> eof) *> notFollowedBy "--"-    pNonTestLine =-      void $ notFollowedBy "-- ==" *> restOfLine-    pInputOutputs =-      parseDescription *> parseInputOutputs <* pEndOfTestBlock---- | Read the test specification from the given Futhark program.-testSpecFromFile :: FilePath -> IO (Either String ProgramTest)-testSpecFromFile path =-  ( either (Left . errorBundlePretty) Right . parse pProgramTest path-      <$> T.readFile path-  )-    `catch` couldNotRead---- | Like 'testSpecFromFile', but kills the process on error.-testSpecFromFileOrDie :: FilePath -> IO ProgramTest-testSpecFromFileOrDie prog = do-  spec_or_err <- testSpecFromFile prog-  case spec_or_err of-    Left err -> do-      putStrLn err-      exitFailure-    Right spec -> return spec---- | Read test specifications from the given path, which can be a file--- or directory containing @.fut@ files and further directories.-testSpecsFromPath :: FilePath -> IO (Either String [(FilePath, ProgramTest)])-testSpecsFromPath path = do-  programs_or_err <- (Right <$> testPrograms path) `catch` couldNotRead-  case programs_or_err of-    Left err -> return $ Left err-    Right programs -> do-      specs_or_errs <- mapM testSpecFromFile programs-      return $ zip programs <$> sequence specs_or_errs---- | Read test specifications from the given paths, which can be a--- files or directories containing @.fut@ files and further--- directories.-testSpecsFromPaths ::-  [FilePath] ->-  IO (Either String [(FilePath, ProgramTest)])-testSpecsFromPaths = fmap (fmap concat . sequence) . mapM testSpecsFromPath---- | Like 'testSpecsFromPaths', but kills the process on errors.-testSpecsFromPathsOrDie ::-  [FilePath] ->-  IO [(FilePath, ProgramTest)]-testSpecsFromPathsOrDie dirs = do-  specs_or_err <- testSpecsFromPaths dirs-  case specs_or_err of-    Left err -> do-      putStrLn err-      exitFailure-    Right specs -> return specs--testPrograms :: FilePath -> IO [FilePath]-testPrograms dir = filter isFut <$> directoryContents dir-  where-    isFut = (== ".fut") . takeExtension- -- | Try to parse a several values from a byte string.  The 'String' -- parameter is used for error messages. valuesFromByteString :: String -> BS.ByteString -> Either String [V.Value]@@ -498,12 +79,12 @@ -- read relative to. getValues :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m [V.Value] getValues _ _ (Values vs) =-  return vs+  pure vs getValues futhark dir v = do   s <- getValuesBS futhark dir v   case valuesFromByteString file s of     Left e -> fail e-    Right vs -> return vs+    Right vs -> pure vs   where     file = case v of       Values {} -> "<values>"@@ -522,14 +103,14 @@ -- guarantee that the resulting byte string yields a readable value. getValuesBS :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m BS.ByteString getValuesBS _ _ (Values vs) =-  return $ BS.fromStrict $ T.encodeUtf8 $ T.unlines $ map V.valueText vs+  pure $ BS.fromStrict $ T.encodeUtf8 $ T.unlines $ map V.valueText vs getValuesBS _ dir (InFile file) =   case takeExtension file of     ".gz" -> liftIO $ do       s <- readAndDecompress file'       case s of         Left e -> fail $ show file ++ ": " ++ show e-        Right s' -> return s'+        Right s' -> pure s'     _ -> liftIO $ BS.readFile file'   where     file' = dir </> file@@ -642,8 +223,7 @@       throwError $ "Unknown builtin procedure: " <> f valuesAsVars server names_and_types futhark dir (ScriptFile f) = do   e <--    either (throwError . T.pack . errorBundlePretty) pure-      . parse (Script.parseExp space) f+    either throwError pure . Script.parseExpFromText f       =<< liftIO (T.readFile (dir </> f))   valuesAsVars server names_and_types futhark dir (ScriptValues e) @@ -665,7 +245,7 @@       withFile (dir </> file) ReadMode (fmap (== genFileSize gen) . hFileSize)         `catch` \ex ->           if isDoesNotExistError ex-            then return False+            then pure False             else E.throw ex   unless exists_and_proper_size $     liftIO $ do@@ -686,7 +266,7 @@   (code, stdout, stderr) <- readProcessWithExitCode futhark ("dataset" : args) mempty   case code of     ExitSuccess ->-      return stdout+      pure stdout     ExitFailure e ->       fail $         "'futhark dataset' failed with exit code " ++ show e ++ " and stderr:\n"@@ -740,22 +320,18 @@     (Succeeds (Just (SuccessValues vals))) ->       Succeeds . Just <$> getValues futhark (takeDirectory prog) vals     Succeeds (Just SuccessGenerateValues) ->-      getExpectedResult-        futhark-        prog-        entry-        tr-          { runExpectedResult =-              Succeeds $-                Just $-                  SuccessValues $-                    InFile $-                      testRunReferenceOutput prog entry tr-          }+      getExpectedResult futhark prog entry tr'+      where+        tr' =+          tr+            { runExpectedResult =+                Succeeds . Just . SuccessValues . InFile $+                  testRunReferenceOutput prog entry tr+            }     Succeeds Nothing ->-      return $ Succeeds Nothing+      pure $ Succeeds Nothing     RunTimeFailure err ->-      return $ RunTimeFailure err+      pure $ RunTimeFailure err  -- | The name we use for compiled programs. binaryName :: FilePath -> FilePath@@ -777,8 +353,8 @@   case futcode of     ExitFailure 127 -> throwError [progNotFound $ T.pack futhark]     ExitFailure _ -> throwError [T.decodeUtf8 stderr]-    ExitSuccess -> return ()-  return (stdout, stderr)+    ExitSuccess -> pure ()+  pure (stdout, stderr)   where     binOutputf = binaryName program     options = [program, "-o", binOutputf] ++ extra_options@@ -844,7 +420,7 @@         (code, stdout, stderr) <- runProgram futhark "" ["-b"] prog entry $ runInput tr         case code of           ExitFailure e ->-            return $+            pure $               Left                 [ T.pack $                     "Reference dataset generation failed with exit code "@@ -856,11 +432,11 @@             let f = file (entry, tr)             liftIO $ createDirectoryIfMissing True $ takeDirectory f             SBS.writeFile f stdout-            return $ Right ()+            pure $ Right ()      case sequence_ res of       Left err -> throwError err-      Right () -> return ()+      Right () -> pure ()   where     file (entry, tr) =       takeDirectory prog </> testRunReferenceOutput prog entry tr@@ -869,24 +445,26 @@      isReferenceMissing (entry, tr)       | Succeeds (Just SuccessGenerateValues) <- runExpectedResult tr =-        liftIO . fmap not . doesFileExist . file $ (entry, tr)+        liftIO $+          ((<) <$> getModificationTime (file (entry, tr)) <*> getModificationTime prog)+            `catch` (\e -> if isDoesNotExistError e then pure True else E.throw e)       | otherwise =-        return False+        pure False  -- | Determine the --tuning options to pass to the program.  The first -- argument is the extension of the tuning file, or 'Nothing' if none -- should be used. determineTuning :: MonadIO m => Maybe FilePath -> FilePath -> m ([String], String)-determineTuning Nothing _ = return ([], mempty)+determineTuning Nothing _ = pure ([], mempty) determineTuning (Just ext) program = do   exists <- liftIO $ doesFileExist (program <.> ext)   if exists     then-      return+      pure         ( ["--tuning", program <.> ext],           " (using " <> takeFileName (program <.> ext) <> ")"         )-    else return ([], mempty)+    else pure ([], mempty)  -- | Check that the result is as expected, and write files and throw -- an error if not.@@ -911,7 +489,7 @@             then mempty             else "\n...and " <> prettyText (length mismatches) <> " other mismatches."     [] ->-      return ()+      pure ()  -- | Create a Futhark server configuration suitable for use when -- testing/benchmarking Futhark programs.

@@ -0,0 +1,463 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Definition and parsing of a test specification.+module Futhark.Test.Spec+  ( testSpecFromProgram,+    testSpecFromProgramOrDie,+    testSpecsFromPaths,+    testSpecsFromPathsOrDie,+    testSpecFromFile,+    testSpecFromFileOrDie,+    ProgramTest (..),+    StructureTest (..),+    StructurePipeline (..),+    WarningTest (..),+    TestAction (..),+    ExpectedError (..),+    InputOutputs (..),+    TestRun (..),+    ExpectedResult (..),+    Success (..),+    Values (..),+    GenValue (..),+    genValueType,+  )+where++import Control.Applicative+import Control.Exception (catch)+import Control.Monad+import Data.Char+import Data.Functor+import Data.List (foldl')+import qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Void+import Futhark.Analysis.Metrics.Type+import Futhark.Data.Parser+import qualified Futhark.Data.Parser as V+import qualified Futhark.Script as Script+import qualified Futhark.Test.Values as V+import Futhark.Util (directoryContents)+import Futhark.Util.Pretty (prettyOneLine)+import System.Exit+import System.FilePath+import System.IO.Error+import Text.Megaparsec hiding (many, some)+import Text.Megaparsec.Char+import Text.Regex.TDFA+import Prelude++-- | 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+  }+  deriving (Show)++-- | How to test a program.+data TestAction+  = CompileTimeFailure ExpectedError+  | RunCases [InputOutputs] [StructureTest] [WarningTest]+  deriving (Show)++-- | Input and output pairs for some entry point(s).+data InputOutputs = InputOutputs+  { iosEntryPoint :: T.Text,+    iosTestRuns :: [TestRun]+  }+  deriving (Show)++-- | The error expected for a negative test.+data ExpectedError+  = AnyError+  | ThisError T.Text Regex++instance Show ExpectedError where+  show AnyError = "AnyError"+  show (ThisError r _) = "ThisError " ++ show r++-- | How a program can be transformed.+data StructurePipeline+  = KernelsPipeline+  | SOACSPipeline+  | SequentialCpuPipeline+  | GpuPipeline+  | NoPipeline+  deriving (Show)++-- | A structure test specifies a compilation pipeline, as well as+-- metrics for the program coming out the other end.+data StructureTest = StructureTest StructurePipeline AstMetrics+  deriving (Show)++-- | A warning test requires that a warning matching the regular+-- expression is produced.  The program must also compile succesfully.+data WarningTest = ExpectedWarning T.Text Regex++instance Show WarningTest where+  show (ExpectedWarning r _) = "ExpectedWarning " ++ T.unpack r++-- | A condition for execution, input, and expected result.+data TestRun = TestRun+  { runTags :: [String],+    runInput :: Values,+    runExpectedResult :: ExpectedResult Success,+    runIndex :: Int,+    runDescription :: String+  }+  deriving (Show)++-- | Several values - either literally, or by reference to a file, or+-- to be generated on demand.  All paths are relative to test program.+data Values+  = Values [V.Value]+  | InFile FilePath+  | GenValues [GenValue]+  | ScriptValues Script.Exp+  | ScriptFile FilePath+  deriving (Show)++data GenValue+  = -- | Generate a value of the given rank and primitive+    -- type.  Scalars are considered 0-ary arrays.+    GenValue V.ValueType+  | -- | A fixed non-randomised primitive value.+    GenPrim V.Value+  deriving (Show)++-- | A prettyprinted representation of type of value produced by a+-- 'GenValue'.+genValueType :: GenValue -> String+genValueType (GenValue (V.ValueType ds t)) =+  concatMap (\d -> "[" ++ show d ++ "]") ds ++ T.unpack (V.primTypeText t)+genValueType (GenPrim v) =+  T.unpack $ V.valueText v++-- | How a test case is expected to terminate.+data ExpectedResult values+  = -- | Execution suceeds, with or without+    -- expected result values.+    Succeeds (Maybe values)+  | -- | Execution fails with this error.+    RunTimeFailure ExpectedError+  deriving (Show)++-- | The result expected from a succesful execution.+data Success+  = -- | These values are expected.+    SuccessValues Values+  | -- | Compute expected values from executing a known-good+    -- reference implementation.+    SuccessGenerateValues+  deriving (Show)++type Parser = Parsec Void T.Text++lexeme :: Parser () -> Parser a -> Parser a+lexeme sep p = p <* sep++-- Like 'lexeme', but does not consume trailing linebreaks.+lexeme' :: Parser a -> Parser a+lexeme' p = p <* hspace++-- Like 'lexstr', but does not consume trailing linebreaks.+lexstr' :: T.Text -> Parser ()+lexstr' = void . try . lexeme' . string++inBraces :: Parser () -> Parser a -> Parser a+inBraces sep = between (lexeme sep "{") (lexeme sep "}")++parseNatural :: Parser () -> Parser Int+parseNatural sep =+  lexeme sep $ foldl' addDigit 0 . map num <$> some digitChar+  where+    addDigit acc x = acc * 10 + x+    num c = ord c - ord '0'++restOfLine :: Parser T.Text+restOfLine = do+  l <- restOfLine_+  if T.null l then void eol else void eol <|> eof+  pure l++restOfLine_ :: Parser T.Text+restOfLine_ = takeWhileP Nothing (/= '\n')++parseDescription :: Parser () -> Parser T.Text+parseDescription sep =+  T.unlines <$> pDescLine `manyTill` pDescriptionSeparator+  where+    pDescLine = restOfLine <* sep+    pDescriptionSeparator = void $ "==" *> sep++parseTags :: Parser () -> Parser [T.Text]+parseTags sep = lexeme' "tags" *> inBraces sep (many parseTag) <|> pure []+  where+    parseTag = T.pack <$> lexeme sep (some $ satisfy tagConstituent)++tagConstituent :: Char -> Bool+tagConstituent c = isAlphaNum c || c == '_' || c == '-'++parseAction :: Parser () -> Parser TestAction+parseAction sep =+  choice+    [ CompileTimeFailure <$> (lexstr' "error:" *> parseExpectedError sep),+      RunCases <$> parseInputOutputs sep+        <*> many (parseExpectedStructure sep)+        <*> many (parseWarning sep)+    ]++parseInputOutputs :: Parser () -> Parser [InputOutputs]+parseInputOutputs sep = do+  entrys <- parseEntryPoints sep+  cases <- parseRunCases sep+  pure $+    if null cases+      then []+      else map (`InputOutputs` cases) entrys++parseEntryPoints :: Parser () -> Parser [T.Text]+parseEntryPoints sep =+  (lexeme' "entry:" *> many entry <* sep) <|> pure ["main"]+  where+    constituent c = not (isSpace c) && c /= '}'+    entry = lexeme' $ T.pack <$> some (satisfy constituent)++parseRunTags :: Parser [String]+parseRunTags = many . try . lexeme' $ do+  s <- some $ satisfy tagConstituent+  guard $ s `notElem` ["input", "structure", "warning"]+  pure s++parseRunCases :: Parser () -> Parser [TestRun]+parseRunCases sep = parseRunCases' (0 :: Int)+  where+    parseRunCases' i =+      (:) <$> parseRunCase i <*> parseRunCases' (i + 1)+        <|> pure []+    parseRunCase i = do+      tags <- parseRunTags+      void $ lexeme sep "input"+      input <-+        if "random" `elem` tags+          then parseRandomValues sep+          else+            if "script" `elem` tags+              then parseScriptValues sep+              else parseValues sep+      expr <- parseExpectedResult sep+      pure $ TestRun tags input expr i $ desc i input++    -- If the file is gzipped, we strip the 'gz' extension from+    -- the dataset name.  This makes it more convenient to rename+    -- from 'foo.in' to 'foo.in.gz', as the reported dataset name+    -- does not change (which would make comparisons to historical+    -- data harder).+    desc _ (InFile path)+      | takeExtension path == ".gz" = dropExtension path+      | otherwise = path+    desc i (Values vs) =+      -- Turn linebreaks into space.+      "#" ++ show i ++ " (\"" ++ unwords (lines vs') ++ "\")"+      where+        vs' = case unwords $ map (T.unpack . V.valueText) vs of+          s+            | length s > 50 -> take 50 s ++ "..."+            | otherwise -> s+    desc _ (GenValues gens) =+      unwords $ map genValueType gens+    desc _ (ScriptValues e) =+      prettyOneLine e+    desc _ (ScriptFile path) =+      path++parseExpectedResult :: Parser () -> Parser (ExpectedResult Success)+parseExpectedResult sep =+  choice+    [ lexeme sep "auto" *> lexeme sep "output" $> Succeeds (Just SuccessGenerateValues),+      Succeeds . Just . SuccessValues <$> (lexeme sep "output" *> parseValues sep),+      RunTimeFailure <$> (lexeme sep "error:" *> parseExpectedError sep),+      pure (Succeeds Nothing)+    ]++parseExpectedError :: Parser () -> Parser ExpectedError+parseExpectedError sep = lexeme sep $ do+  s <- T.strip <$> restOfLine_ <* sep+  if T.null s+    then pure AnyError+    else -- blankCompOpt creates a regular expression that treats+    -- newlines like ordinary characters, which is what we want.+      ThisError s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s)++parseScriptValues :: Parser () -> Parser Values+parseScriptValues sep =+  choice+    [ ScriptValues <$> inBraces sep (Script.parseExp sep),+      ScriptFile . T.unpack <$> (lexeme sep "@" *> lexeme sep nextWord)+    ]+  where+    nextWord = takeWhileP Nothing $ not . isSpace++parseRandomValues :: Parser () -> Parser Values+parseRandomValues sep = GenValues <$> inBraces sep (many (parseGenValue sep))++parseGenValue :: Parser () -> Parser GenValue+parseGenValue sep =+  choice+    [ GenValue <$> lexeme sep parseType,+      GenPrim <$> lexeme sep V.parsePrimValue+    ]++parseValues :: Parser () -> Parser Values+parseValues sep =+  choice+    [ Values <$> inBraces sep (many $ parseValue sep),+      InFile . T.unpack <$> (lexeme sep "@" *> lexeme sep nextWord)+    ]+  where+    nextWord = takeWhileP Nothing $ not . isSpace++parseWarning :: Parser () -> Parser WarningTest+parseWarning sep = lexeme sep "warning:" >> parseExpectedWarning+  where+    parseExpectedWarning = lexeme sep $ do+      s <- T.strip <$> restOfLine_+      ExpectedWarning s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s)++parseExpectedStructure :: Parser () -> Parser StructureTest+parseExpectedStructure sep =+  lexeme sep "structure" *> (StructureTest <$> optimisePipeline sep <*> parseMetrics sep)++optimisePipeline :: Parser () -> Parser StructurePipeline+optimisePipeline sep =+  choice+    [ lexeme sep "distributed" $> KernelsPipeline,+      lexeme sep "gpu" $> GpuPipeline,+      lexeme sep "cpu" $> SequentialCpuPipeline,+      lexeme sep "internalised" $> NoPipeline,+      pure SOACSPipeline+    ]++parseMetrics :: Parser () -> Parser AstMetrics+parseMetrics sep =+  inBraces sep . fmap (AstMetrics . M.fromList) . many $+    (,) <$> (T.pack <$> lexeme sep (some (satisfy constituent))) <*> parseNatural sep+  where+    constituent c = isAlpha c || c == '/'++testSpec :: Parser () -> Parser ProgramTest+testSpec sep =+  ProgramTest <$> parseDescription sep <*> parseTags sep <*> parseAction sep++couldNotRead :: IOError -> IO (Either String a)+couldNotRead = pure . Left . show++pProgramTest :: Parser ProgramTest+pProgramTest = do+  void $ many pNonTestLine+  maybe_spec <-+    optional ("--" *> sep *> testSpec sep) <* pEndOfTestBlock <* many pNonTestLine+  case maybe_spec of+    Just spec+      | RunCases old_cases structures warnings <- testAction spec -> do+        cases <- many $ pInputOutputs <* many pNonTestLine+        pure spec {testAction = RunCases (old_cases ++ concat cases) structures warnings}+      | otherwise ->+        many pNonTestLine *> notFollowedBy "-- ==" *> pure spec+          <?> "no more test blocks, since first test block specifies type error."+    Nothing ->+      eof $> noTest+  where+    sep = void $ hspace *> optional (try $ eol *> "--" *> sep)++    noTest =+      ProgramTest mempty mempty (RunCases mempty mempty mempty)++    pEndOfTestBlock =+      (void eol <|> eof) *> notFollowedBy "--"+    pNonTestLine =+      void $ notFollowedBy "-- ==" *> restOfLine+    pInputOutputs =+      "--" *> sep *> parseDescription sep *> parseInputOutputs sep <* pEndOfTestBlock++-- | Read the test specification from the given Futhark program.+testSpecFromProgram :: FilePath -> IO (Either String ProgramTest)+testSpecFromProgram path =+  ( either (Left . errorBundlePretty) Right . parse pProgramTest path+      <$> T.readFile path+  )+    `catch` couldNotRead++-- | Like 'testSpecFromProgram', but exits the process on error.+testSpecFromProgramOrDie :: FilePath -> IO ProgramTest+testSpecFromProgramOrDie prog = do+  spec_or_err <- testSpecFromProgram prog+  case spec_or_err of+    Left err -> do+      putStrLn err+      exitFailure+    Right spec -> pure spec++testPrograms :: FilePath -> IO [FilePath]+testPrograms dir = filter isFut <$> directoryContents dir+  where+    isFut = (== ".fut") . takeExtension++-- | Read test specifications from the given path, which can be a file+-- or directory containing @.fut@ files and further directories.+testSpecsFromPath :: FilePath -> IO (Either String [(FilePath, ProgramTest)])+testSpecsFromPath path = do+  programs_or_err <- (Right <$> testPrograms path) `catch` couldNotRead+  case programs_or_err of+    Left err -> pure $ Left err+    Right programs -> do+      specs_or_errs <- mapM testSpecFromProgram programs+      pure $ zip programs <$> sequence specs_or_errs++-- | Read test specifications from the given paths, which can be a+-- files or directories containing @.fut@ files and further+-- directories.+testSpecsFromPaths ::+  [FilePath] ->+  IO (Either String [(FilePath, ProgramTest)])+testSpecsFromPaths = fmap (fmap concat . sequence) . mapM testSpecsFromPath++-- | Like 'testSpecsFromPaths', but kills the process on errors.+testSpecsFromPathsOrDie ::+  [FilePath] ->+  IO [(FilePath, ProgramTest)]+testSpecsFromPathsOrDie dirs = do+  specs_or_err <- testSpecsFromPaths dirs+  case specs_or_err of+    Left err -> do+      putStrLn err+      exitFailure+    Right specs -> pure specs++-- | Read a test specification from a file.  Expects only a single+-- block, and no comment prefixes.+testSpecFromFile :: FilePath -> IO (Either String ProgramTest)+testSpecFromFile path =+  ( either (Left . errorBundlePretty) Right . parse (testSpec space) path+      <$> T.readFile path+  )+    `catch` couldNotRead++-- | Like 'testSpecFromFile', but kills the process on errors.+testSpecFromFileOrDie :: FilePath -> IO ProgramTest+testSpecFromFileOrDie dirs = do+  spec_or_err <- testSpecFromFile dirs+  case spec_or_err of+    Left err -> do+      putStrLn err+      exitFailure+    Right spec -> pure spec

@@ -406,7 +406,7 @@  loopMerge' :: [(Ident, Uniqueness)] -> [SubExp] -> [(Param DeclType, SubExp)] loopMerge' vars vals =-  [ (Param pname $ toDecl ptype u, val)+  [ (Param mempty pname $ toDecl ptype u, val)     | ((Ident pname ptype, u), val) <- zip vars vals   ] 

@@ -21,6 +21,7 @@     renameLambda,     renamePat,     renameSomething,+    renameBound,      -- * Renaming annotations     RenameM,@@ -111,7 +112,7 @@   m (PatT dec) renamePat = modifyNameSource . runRenamer . rename'   where-    rename' pat = bind (patNames pat) $ rename pat+    rename' pat = renameBound (patNames pat) $ rename pat  -- | Rename the bound variables in something (does not affect free variables). renameSomething ::@@ -180,14 +181,16 @@     tp' <- rename tp     return $ Ident name' tp' -bind :: [VName] -> RenameM a -> RenameM a-bind vars body = do+-- | Rename variables in binding position.  The provided VNames are+-- associated with new, fresh names in the renaming environment.+renameBound :: [VName] -> RenameM a -> RenameM a+renameBound vars body = do   vars' <- mapM newName vars   -- This works because map union prefers elements from left   -- operand.-  local (bind' vars') body+  local (renameBound' vars') body   where-    bind' vars' env =+    renameBound' vars' env =       env         { envNameMap =             M.fromList (zip vars vars')@@ -201,13 +204,13 @@   where     descend stms' rem_stms = case stmsHead rem_stms of       Nothing -> m stms'-      Just (stm, rem_stms') -> bind (patNames $ stmPat stm) $ do+      Just (stm, rem_stms') -> renameBound (patNames $ stmPat stm) $ do         stm' <- rename stm         descend (stms' <> oneStm stm') rem_stms'  instance Renameable rep => Rename (FunDef rep) where   rename (FunDef entry attrs fname ret params body) =-    bind (map paramName params) $ do+    renameBound (map paramName params) $ do       params' <- mapM rename params       body' <- rename body       ret' <- rename ret@@ -218,7 +221,8 @@   rename (Constant v) = return $ Constant v  instance Rename dec => Rename (Param dec) where-  rename (Param name dec) = Param <$> rename name <*> rename dec+  rename (Param attrs name dec) =+    Param <$> rename attrs <*> rename name <*> rename dec  instance Rename dec => Rename (PatT dec) where   rename (Pat xs) = Pat <$> rename xs@@ -258,11 +262,11 @@       -- It is important that 'i' is renamed before the loop_vars, as       -- 'i' may be used in the annotations for loop_vars (e.g. index       -- functions).-      ForLoop i it boundexp loop_vars -> bind [i] $ do+      ForLoop i it boundexp loop_vars -> renameBound [i] $ do         let (arr_params, loop_arrs) = unzip loop_vars         boundexp' <- rename boundexp         loop_arrs' <- rename loop_arrs-        bind (map paramName params ++ map paramName arr_params) $ do+        renameBound (map paramName params ++ map paramName arr_params) $ do           params' <- mapM rename params           arr_params' <- mapM rename arr_params           i' <- rename i@@ -273,7 +277,7 @@               (ForLoop i' it boundexp' $ zip arr_params' loop_arrs')               loopbody'       WhileLoop cond ->-        bind (map paramName params) $ do+        renameBound (map paramName params) $ do           params' <- mapM rename params           loopbody' <- rename loopbody           cond' <- rename cond@@ -304,7 +308,7 @@  instance Renameable rep => Rename (Lambda rep) where   rename (Lambda params body ret) =-    bind (map paramName params) $ do+    renameBound (map paramName params) $ do       params' <- mapM rename params       body' <- rename body       ret' <- mapM rename ret

@@ -90,8 +90,9 @@       (substituteNames substs dec)  instance Substitute dec => Substitute (Param dec) where-  substituteNames substs (Param name dec) =+  substituteNames substs (Param attrs name dec) =     Param+      (substituteNames substs attrs)       (substituteNames substs name)       (substituteNames substs dec) 

@@ -1503,7 +1503,7 @@   matchPat pat = matchExtPat pat <=< expExtType    default primFParam :: FParamInfo rep ~ DeclType => VName -> PrimType -> TypeM rep (FParam (Aliases rep))-  primFParam name t = return $ Param name (Prim t)+  primFParam name t = return $ Param mempty name (Prim t)    default matchReturnType :: RetType rep ~ DeclExtType => [RetType rep] -> Result -> TypeM rep ()   matchReturnType = matchExtReturnType . map fromDecl

@@ -202,8 +202,10 @@         map mconcat $           M.elems $             M.intersectionWith (zipWith match) poly_fields fields-    match (Scalar (Arrow _ _ poly_t1 poly_t2)) (Scalar (Arrow _ _ t1 t2)) =-      match poly_t1 t1 <> match poly_t2 t2+    match+      (Scalar (Arrow _ _ poly_t1 (RetType _ poly_t2)))+      (Scalar (Arrow _ _ t1 (RetType _ t2))) =+        match poly_t1 t1 <> match poly_t2 t2     match poly_t t       | d1 : _ <- shapeDims (arrayShape poly_t),         d2 : _ <- shapeDims (arrayShape t) =@@ -437,7 +439,7 @@       envShapes = mempty     }   where-    tbind = T.TypeAbbr Unlifted []+    tbind = T.TypeAbbr Unlifted [] . RetType []  i64Env :: M.Map VName Int64 -> Env i64Env = valEnv . M.map f@@ -661,8 +663,8 @@ evalType :: Env -> StructType -> StructType evalType _ (Scalar (Prim pt)) = Scalar $ Prim pt evalType env (Scalar (Record fs)) = Scalar $ Record $ fmap (evalType env) fs-evalType env (Scalar (Arrow () p t1 t2)) =-  Scalar $ Arrow () p (evalType env t1) (evalType env t2)+evalType env (Scalar (Arrow () p t1 (RetType dims t2))) =+  Scalar $ Arrow () p (evalType env t1) (RetType dims (evalType env t2)) evalType env t@(Array _ u _ shape) =   let et = stripArray (shapeRank shape) t       et' = evalType env et@@ -676,7 +678,7 @@     evalDim d = d evalType env t@(Scalar (TypeVar () _ tn args)) =   case lookupType (qualNameFromTypeName tn) env of-    Just (T.TypeAbbr _ ps t') ->+    Just (T.TypeAbbr _ ps (RetType _ t')) ->       let (substs, types) = mconcat $ zipWith matchPtoA ps args           onDim (NamedDim v) = fromMaybe (NamedDim v) $ M.lookup (qualLeaf v) substs           onDim d = d@@ -691,7 +693,7 @@       (M.singleton p $ ConstDim k, mempty)     matchPtoA (TypeParamType l p _) (TypeArgType t' _) =       let t'' = evalType env t'-       in (mempty, M.singleton p $ T.TypeAbbr l [] t'')+       in (mempty, M.singleton p $ T.TypeAbbr l [] $ RetType [] t'')     matchPtoA _ _ = mempty evalType env (Scalar (Sum cs)) = Scalar $ Sum $ (fmap . fmap) (evalType env) cs @@ -725,7 +727,7 @@   -- Eta-expand the rest to make any sizes visible.   etaExpand [] env rettype   where-    etaExpand vs env' (Scalar (Arrow _ _ pt rt)) =+    etaExpand vs env' (Scalar (Arrow _ _ pt (RetType _ rt))) =       return $         ValueFun $ \v -> do           env'' <- matchPat env' (Wildcard (Info $ fromStruct pt) noLoc) v@@ -755,7 +757,7 @@   EvalM TermBinding evalFunctionBinding env tparams ps ret retext fbody = do   let ret' = evalType env ret-      arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt+      arrow (xp, xt) yt = Scalar $ Arrow () xp xt $ RetType [] yt       ftype = foldr (arrow . patternParam) ret' ps    -- Distinguish polymorphic and non-polymorphic bindings here.@@ -861,18 +863,12 @@       v_s = valueShape v       env'' = env' <> i64Env (resolveExistentials (map sizeName sizes) p_t v_s)   eval env'' body-evalAppExp env (LetFun f (tparams, ps, _, Info ret, fbody) body _) = do+evalAppExp env (LetFun f (tparams, ps, _, Info (RetType _ ret), fbody) body _) = do   binding <- evalFunctionBinding env tparams ps ret [] fbody   eval (env {envTerm = M.insert f binding $ envTerm env}) body evalAppExp   env-  ( BinOp-      (op, _)-      op_t-      (x, Info (_, xext))-      (y, Info (_, yext))-      loc-    )+  (BinOp (op, _) op_t (x, Info (_, xext)) (y, Info (_, yext)) loc)     | baseString (qualLeaf op) == "&&" = do       x' <- asBool <$> eval env x       if x'@@ -1062,14 +1058,14 @@ -- that takes an empty tuple '()' as argument!  Zero-parameter lambdas -- can never occur in a well-formed Futhark program, but they are -- convenient in the interpreter.-eval env (Lambda ps body _ (Info (_, rt)) _) =+eval env (Lambda ps body _ (Info (_, RetType _ rt)) _) =   evalFunction env [] ps body rt eval env (OpSection qv (Info t) _) = evalTermVar env qv $ toStruct t-eval env (OpSectionLeft qv _ e (Info (_, _, argext), _) (Info t, Info retext) loc) = do+eval env (OpSectionLeft qv _ e (Info (_, _, argext), _) (Info (RetType _ t), _) loc) = do   v <- evalArg env e argext   f <- evalTermVar env qv (toStruct t)-  returned env t retext =<< apply loc env f v-eval env (OpSectionRight qv _ e (Info _, Info (_, _, argext)) (Info t) loc) = do+  apply loc env f v+eval env (OpSectionRight qv _ e (Info _, Info (_, _, argext)) (Info (RetType _ t)) loc) = do   y <- evalArg env e argext   return $     ValueFun $ \x -> do@@ -1097,14 +1093,14 @@   vs <- mapM (eval env) es   shape <- typeValueShape env $ toStruct t   return $ ValueSum shape c vs-eval env (Attr (AttrAtom "break") e loc) = do+eval env (Attr (AttrAtom (AtomName "break") _) e loc) = do   break (locOf loc)   eval env e-eval env (Attr (AttrAtom "trace") e loc) = do+eval env (Attr (AttrAtom (AtomName "trace") _) e loc) = do   v <- eval env e   trace (locStr (locOf loc)) v   pure v-eval env (Attr (AttrComp "trace" [AttrAtom tag]) e _) = do+eval env (Attr (AttrComp "trace" [AttrAtom (AtomName tag) _] _) e _) = do   v <- eval env e   trace (nameToString tag) v   pure v@@ -1191,7 +1187,7 @@     _ -> error "Expected ModuleFun."  evalDec :: Env -> Dec -> EvalM Env-evalDec env (ValDec (ValBind _ v _ (Info (ret, retext)) tparams ps fbody _ _ _)) = do+evalDec env (ValDec (ValBind _ v _ (Info (RetType _ ret, retext)) tparams ps fbody _ _ _)) = do   binding <- evalFunctionBinding env tparams ps ret retext fbody   return $ env {envTerm = M.insert v binding $ envTerm env} evalDec env (OpenDec me _) = do@@ -1203,10 +1199,8 @@   evalDec env $ LocalDec (OpenDec (ModImport name name' loc) loc) loc evalDec env (LocalDec d _) = evalDec env d evalDec env SigDec {} = return env-evalDec env (TypeDec (TypeBind v l ps t _ _)) = do-  let abbr =-        T.TypeAbbr l ps $-          evalType env $ unInfo $ expandedType t+evalDec env (TypeDec (TypeBind v l ps _ (Info (RetType dims t)) _ _)) = do+  let abbr = T.TypeAbbr l ps . RetType dims $ evalType env t   return env {envType = M.insert v abbr $ envType env} evalDec env (ModDec (ModBind v ps ret body _ loc)) = do   mod <- evalModExp env $ wrapInLambda ps@@ -1893,7 +1887,7 @@      tdef s = do       t <- nameFromString s `M.lookup` namesToPrimTypes-      return $ T.TypeAbbr Unlifted [] $ Scalar $ Prim t+      return $ T.TypeAbbr Unlifted [] $ RetType [] $ Scalar $ Prim t      stream f arg@(ValueArray _ xs) =       let n = ValuePrim $ SignedValue $ Int64Value $ arrayLength xs@@ -1962,9 +1956,9 @@       f <- evalTermVar (ctxEnv ctx) (qualName fname) ft       foldM (apply noLoc mempty) f vs'   where-    updateType (vt : vts) (Scalar (Arrow als u pt rt)) = do+    updateType (vt : vts) (Scalar (Arrow als u pt (RetType dims rt))) = do       checkInput vt pt-      Scalar . Arrow als u (valueStructType vt) <$> updateType vts rt+      Scalar . Arrow als u (valueStructType vt) . RetType dims <$> updateType vts rt     updateType _ t =       Right t 

@@ -76,6 +76,7 @@   "}"                      { tokenC RCURLY }   ","                      { tokenC COMMA }   "_"                      { tokenC UNDERSCORE }+  "?"                      { tokenC QUESTION_MARK }   "->"                     { tokenC RIGHT_ARROW }   ":"                      { tokenC COLON }   ":>"                     { tokenC COLON_GT }@@ -92,6 +93,7 @@   ".."                     { tokenC TWO_DOTS }   "."                      { tokenC DOT }   "!"                      { tokenC BANG }+  "$"                      { tokenC DOLLAR }    @intlit i8               { tokenM $ return . I8LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') }   @intlit i16              { tokenM $ return . I16LIT . readIntegral . T.filter (/= '_') . T.takeWhile (/='i') }@@ -327,11 +329,13 @@            | COMMA            | UNDERSCORE            | RIGHT_ARROW+           | QUESTION_MARK             | EQU            | ASTERISK            | NEGATE            | BANG+           | DOLLAR            | LTH            | HAT            | TILDE

@@ -151,6 +151,7 @@       '->'            { L $$ RIGHT_ARROW }       ':'             { L $$ COLON }       ':>'            { L $$ COLON_GT }+      '?'             { L $$ QUESTION_MARK  }       for             { L $$ FOR }       do              { L $$ DO }       with            { L $$ WITH }@@ -407,20 +408,25 @@              : TypeExp %prec bottom { TypeDecl $1 NoInfo }  TypeAbbr :: { TypeBindBase NoInfo Name }-TypeAbbr : type Liftedness id TypeParams '=' TypeExpDecl+TypeAbbr : type Liftedness id TypeParams '=' TypeExp            { let L _ (ID name) = $3-              in TypeBind name $2 $4 $6 Nothing (srcspan $1 $>) }-         | type Liftedness 'id[' id ']' TypeParams '=' TypeExpDecl+              in TypeBind name $2 $4 $6 NoInfo Nothing (srcspan $1 $>) }+         | type Liftedness 'id[' id ']' TypeParams '=' TypeExp            { let L loc (INDEXING name) = $3; L ploc (ID pname) = $4-             in TypeBind name $2 (TypeParamDim pname ploc:$6) $8 Nothing (srcspan $1 $>) }+             in TypeBind name $2 (TypeParamDim pname ploc:$6) $8 NoInfo Nothing (srcspan $1 $>) }  TypeExp :: { UncheckedTypeExp }          : '(' id ':' TypeExp ')' '->' TypeExp            { let L _ (ID v) = $2 in TEArrow (Just v) $4 $7 (srcspan $1 $>) }          | TypeExpTerm '->' TypeExp            { TEArrow Nothing $1 $3 (srcspan $1 $>) }+         | '?' TypeExpDims '.' TypeExp { TEDim $2 $4 (srcspan $1 $>) }          | TypeExpTerm %prec typeprec { $1 } +TypeExpDims :: { [Name] }+         : '[' id ']'             { let L _ (ID v) = $2 in [v] }+         | '[' id ']' TypeExpDims { let L _ (ID v) = $2 in v : $4 }+ TypeExpTerm :: { UncheckedTypeExp }          : '*' TypeExpTerm            { TEUnique $2 (srcspan $1 $>) }@@ -749,11 +755,12 @@         { let loc = srcspan $1 $> in CasePat $2 $> loc }  CPat :: { PatBase NoInfo Name }-          : CInnerPat ':' TypeExpDecl { PatAscription $1 $3 (srcspan $1 $>) }+          : '#[' AttrInfo ']' CPat    { PatAttr $2 $4 (srcspan $1 $>) }+          | CInnerPat ':' TypeExpDecl { PatAscription $1 $3 (srcspan $1 $>) }           | CInnerPat                 { $1 }-          | Constr ConstrFields           { let (n, loc) = $1;-                                                loc' = srcspan loc $>-                                            in PatConstr n NoInfo $2 loc'}+          | Constr ConstrFields       { let (n, loc) = $1;+                                            loc' = srcspan loc $>+                                        in PatConstr n NoInfo $2 loc'}  CPats1 :: { [PatBase NoInfo Name] }            : CPat               { [$1] }@@ -764,9 +771,9 @@                | '(' BindingBinOp ')'               { Id $2 NoInfo (srcspan $1 $>) }                | '_'                                { Wildcard NoInfo $1 }                | '(' ')'                            { TuplePat [] (srcspan $1 $>) }-               | '(' CPat ')'                   { PatParens $2 (srcspan $1 $>) }-               | '(' CPat ',' CPats1 ')'    { TuplePat ($2:$4) (srcspan $1 $>) }-               | '{' CFieldPats '}'             { RecordPat $2 (srcspan $1 $>) }+               | '(' CPat ')'                       { PatParens $2 (srcspan $1 $>) }+               | '(' CPat ',' CPats1 ')'            { TuplePat ($2:$4) (srcspan $1 $>) }+               | '{' CFieldPats '}'                 { RecordPat $2 (srcspan $1 $>) }                | CaseLiteral                        { PatLit (fst $1) NoInfo (snd $1) }                | Constr                             { let (n, loc) = $1                                                       in PatConstr n NoInfo [] loc }@@ -848,20 +855,21 @@          | intlit { let L loc (INTLIT n) = $1 in (nameFromString (show n), loc) }  Pat :: { PatBase NoInfo Name }-Pat : InnerPat ':' TypeExpDecl { PatAscription $1 $3 (srcspan $1 $>) }-        | InnerPat                 { $1 }+     : '#[' AttrInfo ']' Pat  { PatAttr $2 $4 (srcspan $1 $>) }+     | InnerPat ':' TypeExpDecl { PatAscription $1 $3 (srcspan $1 $>) }+     | InnerPat                 { $1 }  Pats1 :: { [PatBase NoInfo Name] }-           : Pat               { [$1] }-           | Pat ',' Pats1 { $1 : $3 }+       : Pat                    { [$1] }+       | Pat ',' Pats1          { $1 : $3 }  InnerPat :: { PatBase NoInfo Name } InnerPat : id                               { let L loc (ID name) = $1 in Id name NoInfo loc }-             | '(' BindingBinOp ')'             { Id $2 NoInfo (srcspan $1 $>) }-             | '_'                              { Wildcard NoInfo $1 }-             | '(' ')'                          { TuplePat [] (srcspan $1 $>) }+             | '(' BindingBinOp ')'         { Id $2 NoInfo (srcspan $1 $>) }+             | '_'                          { Wildcard NoInfo $1 }+             | '(' ')'                      { TuplePat [] (srcspan $1 $>) }              | '(' Pat ')'                  { PatParens $2 (srcspan $1 $>) }-             | '(' Pat ',' Pats1 ')'    { TuplePat ($2:$4) (srcspan $1 $>) }+             | '(' Pat ',' Pats1 ')'        { TuplePat ($2:$4) (srcspan $1 $>) }              | '{' FieldPats '}'            { RecordPat $2 (srcspan $1 $>) }  FieldPat :: { (Name, PatBase NoInfo Name) }@@ -884,12 +892,16 @@ maybeAscription(p) : ':' p { Just $2 }                    |       { Nothing } -AttrInfo :: { AttrInfo }-         : id { let L _ (ID s) = $1 in AttrAtom s }-         | id '('       ')' { let L _ (ID s) = $1 in AttrComp s [] }-         | id '(' Attrs ')' { let L _ (ID s) = $1 in AttrComp s $3 }+AttrAtom :: { (AttrAtom Name, SrcLoc) }+          : id     { let L loc (ID s) =     $1 in (AtomName s, loc) }+          | intlit { let L loc (INTLIT x) = $1 in (AtomInt x, loc) } -Attrs :: { [AttrInfo] }+AttrInfo :: { AttrInfo Name }+         : AttrAtom         { uncurry AttrAtom $1 }+         | id '('       ')' { let L _ (ID s) = $1 in AttrComp s [] (srcspan $1 $>) }+         | id '(' Attrs ')' { let L _ (ID s) = $1 in AttrComp s $3 (srcspan $1 $>) }++Attrs :: { [AttrInfo Name] }        : AttrInfo           { [$1] }        | AttrInfo ',' Attrs { $1 : $3 } @@ -1000,14 +1012,14 @@ addDocSpec doc (ModSpec name se _ loc) = ModSpec name se (Just doc) loc addDocSpec _ spec = spec -addAttr :: AttrInfo -> UncheckedDec -> UncheckedDec+addAttr :: AttrInfo Name -> UncheckedDec -> UncheckedDec addAttr attr (ValDec val) =   ValDec $ val { valBindAttrs = attr : valBindAttrs val } addAttr attr dec =   dec  -- We will extend this function once we actually start tracking these.-addAttrSpec :: AttrInfo -> UncheckedSpec -> UncheckedSpec+addAttrSpec :: AttrInfo Name -> UncheckedSpec -> UncheckedSpec addAttrSpec _attr dec = dec  reverseNonempty :: (a, [a]) -> (a, [a])

@@ -119,6 +119,12 @@ instance Pretty (ShapeDecl Bool) where   ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds) +instance Pretty (ShapeDecl dim) => Pretty (RetTypeBase dim as) where+  ppr = pprPrec 0+  pprPrec p (RetType [] t) = pprPrec p t+  pprPrec _ (RetType dims t) =+    text "?" <> mconcat (map (brackets . pprName) dims) <> text "." <> ppr t+ instance Pretty (ShapeDecl dim) => Pretty (ScalarTypeBase dim as) where   ppr = pprPrec 0   pprPrec _ (Prim et) = ppr et@@ -175,6 +181,8 @@     align $ cat $ punctuate (text " |" <> softline) $ map ppConstr cs     where       ppConstr (name, fs) = text "#" <> ppr name <+> sep (map ppr fs)+  ppr (TEDim dims te _) =+    text "?" <> mconcat (map (brackets . pprName) dims) <> text "." <> ppr te  instance (Eq vn, IsName vn) => Pretty (TypeArgExp vn) where   ppr (TypeArgExpDim d _) = brackets $ ppr d@@ -356,10 +364,14 @@     text "#[" <> ppr attr <> text "]" </> pprPrec (-1) e   pprPrec i (AppExp e _) = pprPrec i e -instance Pretty AttrInfo where-  ppr (AttrAtom attr) = ppr attr-  ppr (AttrComp f attrs) = ppr f <> parens (commasep $ map ppr attrs)+instance IsName vn => Pretty (AttrAtom vn) where+  ppr (AtomName v) = ppr v+  ppr (AtomInt x) = ppr x +instance IsName vn => Pretty (AttrInfo vn) where+  ppr (AttrAtom attr _) = ppr attr+  ppr (AttrComp f attrs _) = ppr f <> parens (commasep $ map ppr attrs)+ instance (Eq vn, IsName vn, Annot f) => Pretty (FieldBase f vn) where   ppr (RecordFieldExplicit name e _) = ppr name <> equals <> ppr e   ppr (RecordFieldImplicit name _ _) = pprName name@@ -395,6 +407,7 @@     Nothing -> text "_"   ppr (PatLit e _ _) = ppr e   ppr (PatConstr n _ ps _) = text "#" <> ppr n <+> sep (map ppr ps)+  ppr (PatAttr attr p _) = text "#[" <> ppr attr <> text "]" <+/> ppr p  ppAscription :: Pretty t => Maybe t -> Doc ppAscription Nothing = mempty@@ -433,11 +446,11 @@   ppr Lifted = text "^"  instance (Eq vn, IsName vn, Annot f) => Pretty (TypeBindBase f vn) where-  ppr (TypeBind name l params usertype _ _) =+  ppr (TypeBind name l params te rt _ _) =     text "type" <> ppr l <+> pprName name       <+> spread (map ppr params)       <+> equals-      <+> ppr usertype+      <+> maybe (ppr te) ppr (unAnnot rt)  instance (Eq vn, IsName vn) => Pretty (TypeParamBase vn) where   ppr (TypeParamDim name _) = brackets $ pprName name

@@ -65,7 +65,6 @@     addAliases,     setUniqueness,     noSizes,-    anySizes,     traverseDims,     DimPos (..),     mustBeExplicit,@@ -132,7 +131,7 @@ arrayShape (Array _ _ _ ds) = ds arrayShape _ = mempty --- | Return any shape declarations in the type, with duplicates+-- | Return any free shape declarations in the type, with duplicates -- removed. nestedDims :: TypeBase (DimDecl VName) as -> [DimDecl VName] nestedDims t =@@ -145,8 +144,10 @@       mempty     Scalar (Sum cs) ->       nubOrd $ foldMap (foldMap nestedDims) cs-    Scalar (Arrow _ v t1 t2) ->-      filter (notV v) $ nestedDims t1 <> nestedDims t2+    Scalar (Arrow _ v t1 (RetType dims t2)) ->+      filter (notV v) $ filter (`notElem` dims') $ nestedDims t1 <> nestedDims t2+      where+        dims' = map (NamedDim . qualName) dims     Scalar (TypeVar _ _ _ targs) ->       concatMap typeArgDims targs   where@@ -160,10 +161,6 @@ noSizes :: TypeBase (DimDecl vn) as -> TypeBase () as noSizes = first $ const () --- | Change all size annotations to be 'AnyDim'.-anySizes :: TypeBase (DimDecl vn) as -> TypeBase (DimDecl vn) as-anySizes = first $ const $ AnyDim Nothing- -- | Where does this dimension occur? data DimPos   = -- | Immediately in the argument to 'traverseDims'.@@ -203,12 +200,14 @@       Scalar . Sum <$> traverse (traverse (go bound b)) cs     go _ _ (Scalar (Prim t)) =       pure $ Scalar $ Prim t-    go bound _ (Scalar (Arrow als p t1 t2)) =-      Scalar <$> (Arrow als p <$> go bound' PosParam t1 <*> go bound' PosReturn t2)+    go bound _ (Scalar (Arrow als p t1 (RetType dims t2))) =+      Scalar <$> (Arrow als p <$> go bound' PosParam t1 <*> (RetType dims <$> go bound' PosReturn t2))       where-        bound' = case p of-          Named p' -> S.insert p' bound-          Unnamed -> bound+        bound' =+          S.fromList dims+            <> case p of+              Named p' -> S.insert p' bound+              Unnamed -> bound      onTypeArg bound b (TypeArgDim d loc) =       TypeArgDim <$> f bound b d <*> pure loc@@ -272,7 +271,7 @@ diet :: TypeBase shape as -> Diet diet (Scalar (Record ets)) = RecordDiet $ fmap diet ets diet (Scalar (Prim _)) = Observe-diet (Scalar (Arrow _ _ t1 t2)) = FuncDiet (diet t1) (diet t2)+diet (Scalar (Arrow _ _ t1 (RetType _ t2))) = FuncDiet (diet t1) (diet t2) diet (Array _ Unique _ _) = Consume diet (Array _ Nonunique _ _) = Observe diet (Scalar (TypeVar _ Unique _ _)) = Consume@@ -348,8 +347,8 @@  -- | Create a record type corresponding to a tuple with the given -- element types.-tupleRecord :: [TypeBase dim as] -> TypeBase dim as-tupleRecord = Scalar . Record . M.fromList . zip tupleFieldNames+tupleRecord :: [TypeBase dim as] -> ScalarTypeBase dim as+tupleRecord = Record . M.fromList . zip tupleFieldNames  -- | Does this type corespond to a tuple?  If so, return the elements -- of that tuple.@@ -423,8 +422,8 @@         M.map           (uncurry $ zipWith combineTypeShapes)           (M.intersectionWith (,) cs1 cs2)-combineTypeShapes (Scalar (Arrow als1 p1 a1 b1)) (Scalar (Arrow als2 _p2 a2 b2)) =-  Scalar $ Arrow (als1 <> als2) p1 (combineTypeShapes a1 a2) (combineTypeShapes b1 b2)+combineTypeShapes (Scalar (Arrow als1 p1 a1 (RetType dims1 b1))) (Scalar (Arrow als2 _p2 a2 (RetType _ b2))) =+  Scalar $ Arrow (als1 <> als2) p1 (combineTypeShapes a1 a2) (RetType dims1 (combineTypeShapes b1 b2)) combineTypeShapes (Scalar (TypeVar als1 u1 v targs1)) (Scalar (TypeVar als2 _ _ targs2)) =   Scalar $ TypeVar (als1 <> als2) u1 v $ zipWith f targs1 targs2   where@@ -441,45 +440,60 @@     u1 combineTypeShapes _ new_tp = new_tp --- | Match the dimensions of otherwise assumed-equal types.+-- | Match the dimensions of otherwise assumed-equal types.  The+-- combining function is also passed the names bound within the type+-- (from named parameters or return types). matchDims ::+  forall as m d1 d2.   (Monoid as, Monad m) =>-  (d1 -> d2 -> m d1) ->+  ([VName] -> d1 -> d2 -> m d1) ->   TypeBase d1 as ->   TypeBase d2 as ->   m (TypeBase d1 as)-matchDims onDims t1 t2 =-  case (t1, t2) of-    (Array als1 u1 et1 shape1, Array als2 u2 et2 shape2) ->-      flip setAliases (als1 <> als2)-        <$> ( arrayOf-                <$> matchDims onDims (Scalar et1) (Scalar et2)-                <*> onShapes shape1 shape2-                <*> pure (min u1 u2)-            )-    (Scalar (Record f1), Scalar (Record f2)) ->-      Scalar . Record-        <$> traverse (uncurry (matchDims onDims)) (M.intersectionWith (,) f1 f2)-    (Scalar (Sum cs1), Scalar (Sum cs2)) ->-      Scalar . Sum-        <$> traverse-          (traverse (uncurry (matchDims onDims)))-          (M.intersectionWith zip cs1 cs2)-    (Scalar (Arrow als1 p1 a1 b1), Scalar (Arrow als2 _p2 a2 b2)) ->-      Scalar-        <$> (Arrow (als1 <> als2) p1 <$> matchDims onDims a1 a2 <*> matchDims onDims b1 b2)-    ( Scalar (TypeVar als1 u v targs1),-      Scalar (TypeVar als2 _ _ targs2)-      ) ->-        Scalar . TypeVar (als1 <> als2) u v <$> zipWithM matchTypeArg targs1 targs2-    _ -> return t1+matchDims onDims = matchDims' mempty   where-    matchTypeArg ta@TypeArgType {} _ = return ta-    matchTypeArg a _ = return a+    matchDims' ::+      forall as'. Monoid as' => [VName] -> TypeBase d1 as' -> TypeBase d2 as' -> m (TypeBase d1 as')+    matchDims' bound t1 t2 =+      case (t1, t2) of+        (Array als1 u1 et1 shape1, Array als2 u2 et2 shape2) ->+          flip setAliases (als1 <> als2)+            <$> ( arrayOf+                    <$> matchDims' bound (Scalar et1) (Scalar et2)+                    <*> onShapes bound shape1 shape2+                    <*> pure (min u1 u2)+                )+        (Scalar (Record f1), Scalar (Record f2)) ->+          Scalar . Record+            <$> traverse (uncurry (matchDims' bound)) (M.intersectionWith (,) f1 f2)+        (Scalar (Sum cs1), Scalar (Sum cs2)) ->+          Scalar . Sum+            <$> traverse+              (traverse (uncurry (matchDims' bound)))+              (M.intersectionWith zip cs1 cs2)+        ( Scalar (Arrow als1 p1 a1 (RetType dims1 b1)),+          Scalar (Arrow als2 p2 a2 (RetType dims2 b2))+          ) ->+            let bound' = mapMaybe maybePName [p1, p2] <> dims1 <> dims2 <> bound+             in Scalar+                  <$> ( Arrow (als1 <> als2) p1 <$> matchDims' bound' a1 a2+                          <*> (RetType dims1 <$> matchDims' bound' b1 b2)+                      )+        ( Scalar (TypeVar als1 u v targs1),+          Scalar (TypeVar als2 _ _ targs2)+          ) ->+            Scalar . TypeVar (als1 <> als2) u v <$> zipWithM matchTypeArg targs1 targs2+        _ -> return t1 -    onShapes shape1 shape2 =-      ShapeDecl <$> zipWithM onDims (shapeDims shape1) (shapeDims shape2)+    matchTypeArg ta@TypeArgType {} _ = pure ta+    matchTypeArg a _ = pure a +    maybePName (Named v) = Just v+    maybePName Unnamed = Nothing++    onShapes bound shape1 shape2 =+      ShapeDecl <$> zipWithM (onDims bound) (shapeDims shape1) (shapeDims shape2)+ -- | Set the uniqueness attribute of a type.  If the type is a record -- or sum type, the uniqueness of its components will be modified. setUniqueness :: TypeBase dim as -> Uniqueness -> TypeBase dim as@@ -529,19 +543,6 @@ valueType (PrimValue bv) = Scalar $ Prim $ primValueType bv valueType (ArrayValue _ t) = t --- | The type is leaving a scope, so clean up any aliases that--- reference the bound variables, and turn any dimensions that name--- them into AnyDim instead.-unscopeType :: S.Set VName -> PatType -> PatType-unscopeType bound_here t = first onDim $ t `addAliases` S.map unbind-  where-    unbind (AliasBound v) | v `S.member` bound_here = AliasFree v-    unbind a = a-    onDim (NamedDim qn)-      | qualLeaf qn `S.member` bound_here =-        AnyDim $ Just $ qualLeaf qn-    onDim d = d- -- | The type of an Futhark term.  The aliasing will refer to itself, if -- the term is a non-tuple-typed variable. typeOf :: ExpBase Info VName -> PatType@@ -550,7 +551,7 @@ typeOf (FloatLit _ (Info t) _) = t typeOf (Parens e _) = typeOf e typeOf (QualParens _ e _) = typeOf e-typeOf (TupLit es _) = tupleRecord $ map typeOf es+typeOf (TupLit es _) = Scalar $ tupleRecord $ map typeOf es typeOf (RecordLit fs _) =   -- Reverse, because M.unions is biased to the left.   Scalar $ Record $ M.unions $ reverse $ map record fs@@ -576,14 +577,14 @@ typeOf (RecordUpdate _ _ _ (Info t) _) = t typeOf (Assert _ e _ _) = typeOf e typeOf (Lambda params _ _ (Info (als, t)) _) =-  unscopeType bound_here $ foldr (arrow . patternParam) t params `setAliases` als+  let RetType [] t' = foldr (arrow . patternParam) t params+   in t' `setAliases` als   where-    bound_here =-      S.map identName (mconcat $ map patIdents params)-        `S.difference` S.fromList (mapMaybe (named . patternParam) params)-    arrow (px, tx) y = Scalar $ Arrow () px tx y-    named (Named x, _) = Just x-    named (Unnamed, _) = Nothing+    arrow (Named v, x) (RetType dims y)+      | v `S.member` typeDimNames y =+        RetType [] $ Scalar $ Arrow () (Named v) x $ RetType (v : dims) y+    arrow (pn, tx) y =+      RetType [] $ Scalar $ Arrow () pn tx y typeOf (OpSection _ (Info t) _) =   t typeOf (OpSectionLeft _ _ _ (_, Info (pn, pt2)) (Info ret, _) _) =@@ -598,15 +599,17 @@  -- | @foldFunType ts ret@ creates a function type ('Arrow') that takes -- @ts@ as parameters and returns @ret@.-foldFunType :: Monoid as => [TypeBase dim as] -> TypeBase dim as -> TypeBase dim as-foldFunType ps ret = foldr arrow ret ps+foldFunType :: Monoid as => [TypeBase dim as] -> RetTypeBase dim as -> TypeBase dim as+foldFunType ps ret =+  let RetType _ t = foldr arrow ret ps+   in t   where-    arrow t1 t2 = Scalar $ Arrow mempty Unnamed t1 t2+    arrow t1 t2 = RetType [] $ Scalar $ Arrow mempty Unnamed t1 t2  -- | Extract the parameter types and return type from a type. -- If the type is not an arrow type, the list of parameter types is empty. unfoldFunType :: TypeBase dim as -> ([TypeBase dim as], TypeBase dim as)-unfoldFunType (Scalar (Arrow _ _ t1 t2)) =+unfoldFunType (Scalar (Arrow _ _ t1 (RetType _ t2))) =   let (ps, r) = unfoldFunType t2    in (t1 : ps, r) unfoldFunType t = ([], t)@@ -620,10 +623,12 @@   )  -- | The type of a function with the given parameters and return type.-funType :: [PatBase Info VName] -> StructType -> StructType-funType params ret = foldr (arrow . patternParam) ret params+funType :: [PatBase Info VName] -> StructRetType -> StructType+funType params ret =+  let RetType _ t = foldr (arrow . patternParam) ret params+   in t   where-    arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt+    arrow (xp, xt) yt = RetType [] $ Scalar $ Arrow () xp xt yt  -- | The type names mentioned in a type. typeVars :: Monoid as => TypeBase dim as -> S.Set VName@@ -632,7 +637,7 @@     Scalar Prim {} -> mempty     Scalar (TypeVar _ _ tn targs) ->       mconcat $ typeVarFree tn : map typeArgFree targs-    Scalar (Arrow _ _ t1 t2) -> typeVars t1 <> typeVars t2+    Scalar (Arrow _ _ t1 (RetType _ t2)) -> typeVars t1 <> typeVars t2     Scalar (Record fields) -> foldMap typeVars fields     Scalar (Sum cs) -> mconcat $ (foldMap . fmap) typeVars cs     Array _ _ rt _ -> typeVars $ Scalar rt@@ -663,12 +668,12 @@   patternDimNames p <> typeDimNames t patternDimNames (PatLit _ (Info tp) _) = typeDimNames tp patternDimNames (PatConstr _ _ ps _) = foldMap patternDimNames ps+patternDimNames (PatAttr _ p _) = patternDimNames p --- | Extract all the shape names that occur in a given type.+-- | Extract all the shape names that occur free in a given type. typeDimNames :: TypeBase (DimDecl VName) als -> S.Set VName typeDimNames = foldMap dimName . nestedDims   where-    dimName :: DimDecl VName -> S.Set VName     dimName (NamedDim qn) = S.singleton $ qualLeaf qn     dimName _ = mempty @@ -684,6 +689,7 @@   PatAscription p _ _ -> patternOrderZero p   PatLit _ (Info t) _ -> orderZero t   PatConstr _ _ ps _ -> all patternOrderZero ps+  PatAttr _ p _ -> patternOrderZero p  -- | The set of identifiers bound in a pattern. patIdents :: (Functor f, Ord vn) => PatBase f vn -> S.Set (IdentBase f vn)@@ -695,6 +701,7 @@ patIdents (PatAscription p _ _) = patIdents p patIdents PatLit {} = mempty patIdents (PatConstr _ _ ps _) = mconcat $ map patIdents ps+patIdents (PatAttr _ p _) = patIdents p  -- | The set of names bound in a pattern. patNames :: (Functor f, Ord vn) => PatBase f vn -> S.Set vn@@ -706,6 +713,7 @@ patNames (PatAscription p _ _) = patNames p patNames PatLit {} = mempty patNames (PatConstr _ _ ps _) = mconcat $ map patNames ps+patNames (PatAttr _ p _) = patNames p  -- | A mapping from names bound in a map to their identifier. patternMap :: (Functor f) => PatBase f VName -> M.Map VName (IdentBase f VName)@@ -719,11 +727,12 @@ patternType (Wildcard (Info t) _) = t patternType (PatParens p _) = patternType p patternType (Id _ (Info t) _) = t-patternType (TuplePat pats _) = tupleRecord $ map patternType pats+patternType (TuplePat pats _) = Scalar $ tupleRecord $ map patternType pats patternType (RecordPat fs _) = Scalar $ Record $ patternType <$> M.fromList fs patternType (PatAscription p _ _) = patternType p patternType (PatLit _ (Info t) _) = t patternType (PatConstr _ (Info t) _ _) = t+patternType (PatAttr _ p _) = patternType p  -- | The type matched by the pattern, including shape declarations if present. patternStructType :: PatBase Info VName -> StructType@@ -734,6 +743,8 @@ patternParam :: PatBase Info VName -> (PName, StructType) patternParam (PatParens p _) =   patternParam p+patternParam (PatAttr _ p _) =+  patternParam p patternParam (PatAscription (Id v _ _) td _) =   (Named v, unInfo $ expandedType td) patternParam (Id v (Info t) _) =@@ -762,7 +773,7 @@ data Intrinsic   = IntrinsicMonoFun [PrimType] PrimType   | IntrinsicOverloadedFun [PrimType] [Maybe PrimType] (Maybe PrimType)-  | IntrinsicPolyFun [TypeParamBase VName] [StructType] StructType+  | IntrinsicPolyFun [TypeParamBase VName] [StructType] (RetTypeBase (DimDecl VName) ())   | IntrinsicType Liftedness [TypeParamBase VName] StructType   | IntrinsicEquality -- Special cased. @@ -817,7 +828,7 @@                  IntrinsicPolyFun                    [tp_a, sp_n, sp_m]                    [Array () Nonunique t_a (shape [n, m])]-                   $ Array () Nonunique t_a (ShapeDecl [AnyDim Nothing])+                   $ RetType [k] $ Array () Nonunique t_a $ shape [k]                ),                ( "unflatten",                  IntrinsicPolyFun@@ -826,25 +837,26 @@                      Scalar $ Prim $ Signed Int64,                      Array () Nonunique t_a (shape [n])                    ]-                   $ Array () Nonunique t_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing]+                   $ RetType [k, m] $+                     Array () Nonunique t_a $ shape [k, m]                ),                ( "concat",                  IntrinsicPolyFun                    [tp_a, sp_n, sp_m]                    [arr_a $ shape [n], arr_a $ shape [m]]-                   $ uarr_a $ ShapeDecl [AnyDim Nothing]+                   $ RetType [k] $ uarr_a $ shape [k]                ),                ( "rotate",                  IntrinsicPolyFun                    [tp_a, sp_n]                    [Scalar $ Prim $ Signed Int64, arr_a $ shape [n]]-                   $ arr_a $ shape [n]+                   $ RetType [] $ arr_a $ shape [n]                ),                ( "transpose",                  IntrinsicPolyFun                    [tp_a, sp_n, sp_m]                    [arr_a $ shape [n, m]]-                   $ arr_a $ shape [m, n]+                   $ RetType [] $ arr_a $ shape [m, n]                ),                ( "scatter",                  IntrinsicPolyFun@@ -853,7 +865,7 @@                      Array () Nonunique (Prim $ Signed Int64) (shape [l]),                      Array () Nonunique t_a (shape [l])                    ]-                   $ Array () Unique t_a (shape [n])+                   $ RetType [] $ Array () Unique t_a (shape [n])                ),                ( "scatter_2d",                  IntrinsicPolyFun@@ -862,7 +874,7 @@                      Array () Nonunique (tupInt64 2) (shape [l]),                      Array () Nonunique t_a (shape [l])                    ]-                   $ uarr_a $ shape [n, m]+                   $ RetType [] $ uarr_a $ shape [n, m]                ),                ( "scatter_3d",                  IntrinsicPolyFun@@ -871,21 +883,20 @@                      Array () Nonunique (tupInt64 3) (shape [l]),                      Array () Nonunique t_a (shape [l])                    ]-                   (uarr_a $ shape [n, m, k])+                   $ RetType [] $ uarr_a $ shape [n, m, k]                ),                ( "zip",                  IntrinsicPolyFun                    [tp_a, tp_b, sp_n]                    [arr_a (shape [n]), arr_b (shape [n])]-                   $ tuple_uarr (Scalar t_a) (Scalar t_b) $ shape [n]+                   $ RetType [] $ tuple_uarr (Scalar t_a) (Scalar t_b) $ shape [n]                ),                ( "unzip",                  IntrinsicPolyFun                    [tp_a, tp_b, sp_n]                    [tuple_arr (Scalar t_a) (Scalar t_b) $ shape [n]]-                   ( Scalar . Record . M.fromList $-                       zip tupleFieldNames [arr_a $ shape [n], arr_b $ shape [n]]-                   )+                   $ RetType [] . Scalar . Record . M.fromList $+                     zip tupleFieldNames [arr_a $ shape [n], arr_b $ shape [n]]                ),                ( "hist",                  IntrinsicPolyFun@@ -897,7 +908,7 @@                      Array () Nonunique (Prim $ Signed Int64) (shape [m]),                      arr_a (shape [m])                    ]-                   (uarr_a $ shape [n])+                   $ RetType [] $ uarr_a $ shape [n]                ),                ( "map",                  IntrinsicPolyFun@@ -905,7 +916,7 @@                    [ Scalar t_a `arr` Scalar t_b,                      arr_a $ shape [n]                    ]-                   $ uarr_b $ shape [n]+                   $ RetType [] $ uarr_b $ shape [n]                ),                ( "reduce",                  IntrinsicPolyFun@@ -914,7 +925,7 @@                      Scalar t_a,                      arr_a $ shape [n]                    ]-                   $ Scalar t_a+                   $ RetType [] $ Scalar t_a                ),                ( "reduce_comm",                  IntrinsicPolyFun@@ -923,7 +934,7 @@                      Scalar t_a,                      arr_a $ shape [n]                    ]-                   $ Scalar t_a+                   $ RetType [] $ Scalar t_a                ),                ( "scan",                  IntrinsicPolyFun@@ -932,7 +943,7 @@                      Scalar t_a,                      arr_a $ shape [n]                    ]-                   $ uarr_a $ shape [n]+                   $ RetType [] $ uarr_a $ shape [n]                ),                ( "partition",                  IntrinsicPolyFun@@ -941,10 +952,11 @@                      Scalar t_a `arr` Scalar (Prim $ Signed Int64),                      arr_a $ shape [n]                    ]-                   ( tupleRecord-                       [ uarr_a $ ShapeDecl [AnyDim Nothing],-                         Array () Unique (Prim $ Signed Int64) (shape [n])-                       ]+                   ( RetType [m] . Scalar $+                       tupleRecord+                         [ uarr_a $ shape [k],+                           Array () Unique (Prim $ Signed Int64) (shape [n])+                         ]                    )                ),                ( "map_stream",@@ -953,7 +965,7 @@                    [ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb),                      arr_a $ shape [n]                    ]-                   $ uarr_b $ shape [n]+                   $ RetType [] $ uarr_b $ shape [n]                ),                ( "map_stream_per",                  IntrinsicPolyFun@@ -961,7 +973,7 @@                    [ Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` arr_kb),                      arr_a $ shape [n]                    ]-                   (uarr_b $ shape [n])+                   $ RetType [] $ uarr_b $ shape [n]                ),                ( "reduce_stream",                  IntrinsicPolyFun@@ -970,7 +982,7 @@                      Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b),                      arr_a $ shape [n]                    ]-                   $ Scalar t_b+                   $ RetType [] $ Scalar t_b                ),                ( "reduce_stream_per",                  IntrinsicPolyFun@@ -979,7 +991,7 @@                      Scalar (Prim $ Signed Int64) `karr` (arr_ka `arr` Scalar t_b),                      arr_a $ shape [n]                    ]-                   $ Scalar t_b+                   $ RetType [] $ Scalar t_b                ),                ( "acc_write",                  IntrinsicPolyFun@@ -988,7 +1000,7 @@                      Scalar (Prim $ Signed Int64),                      Scalar t_a                    ]-                   $ Scalar $ accType arr_ka+                   $ RetType [] $ Scalar $ accType arr_ka                ),                ( "scatter_stream",                  IntrinsicPolyFun@@ -1000,7 +1012,7 @@                              ),                      arr_b $ shape [n]                    ]-                   uarr_ka+                   $ RetType [] uarr_ka                ),                ( "hist_stream",                  IntrinsicPolyFun@@ -1014,7 +1026,7 @@                              ),                      arr_b $ shape [n]                    ]-                   $ uarr_a $ shape [k]+                   $ RetType [] $ uarr_a $ shape [k]                )              ]           ++@@ -1029,7 +1041,7 @@                   Scalar (Prim $ Signed Int64),                   Scalar (Prim $ Signed Int64)                 ]-                $ arr_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing]+                $ RetType [m, k] $ arr_a $ shape [m, k]             ),             ( "flat_update_2d",               IntrinsicPolyFun@@ -1040,7 +1052,7 @@                   Scalar (Prim $ Signed Int64),                   arr_a $ shape [k, l]                 ]-                $ uarr_a $ shape [n]+                $ RetType [] $ uarr_a $ shape [n]             ),             ( "flat_index_3d",               IntrinsicPolyFun@@ -1054,7 +1066,7 @@                   Scalar (Prim $ Signed Int64),                   Scalar (Prim $ Signed Int64)                 ]-                $ arr_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing, AnyDim Nothing]+                $ RetType [m, k, l] $ arr_a $ shape [m, k, l]             ),             ( "flat_update_3d",               IntrinsicPolyFun@@ -1066,7 +1078,7 @@                   Scalar (Prim $ Signed Int64),                   arr_a $ shape [k, l, p]                 ]-                $ uarr_a $ shape [n]+                $ RetType [] $ uarr_a $ shape [n]             ),             ( "flat_index_4d",               IntrinsicPolyFun@@ -1082,7 +1094,7 @@                   Scalar (Prim $ Signed Int64),                   Scalar (Prim $ Signed Int64)                 ]-                $ arr_a $ ShapeDecl [AnyDim Nothing, AnyDim Nothing, AnyDim Nothing, AnyDim Nothing]+                $ RetType [m, k, l, p] $ arr_a $ shape [m, k, l, p]             ),             ( "flat_update_4d",               IntrinsicPolyFun@@ -1095,7 +1107,7 @@                   Scalar (Prim $ Signed Int64),                   arr_a $ shape [k, l, p, q]                 ]-                $ uarr_a $ shape [n]+                $ RetType [] $ uarr_a $ shape [n]             )           ]   where@@ -1122,12 +1134,12 @@         (Record (M.fromList $ zip tupleFieldNames [x, y]))     tuple_uarr x y s = tuple_arr x y s `setUniqueness` Unique -    arr x y = Scalar $ Arrow mempty Unnamed x y+    arr x y = Scalar $ Arrow mempty Unnamed x (RetType [] y)      arr_ka = Array () Nonunique t_a (ShapeDecl [NamedDim $ qualName k])     uarr_ka = Array () Unique t_a (ShapeDecl [NamedDim $ qualName k])     arr_kb = Array () Nonunique t_b (ShapeDecl [NamedDim $ qualName k])-    karr x y = Scalar $ Arrow mempty (Named k) x y+    karr x y = Scalar $ Arrow mempty (Named k) x (RetType [] y)      accType t =       TypeVar () Unique (typeName (fst intrinsicAcc)) [TypeArgType t mempty]

@@ -55,8 +55,8 @@   mconcat $ map patternDefs pats patternDefs (RecordPat fields _) =   mconcat $ map (patternDefs . snd) fields-patternDefs (PatParens pat _) =-  patternDefs pat+patternDefs (PatParens pat _) = patternDefs pat+patternDefs (PatAttr _ pat _) = patternDefs pat patternDefs Wildcard {} = mempty patternDefs PatLit {} = mempty patternDefs (PatAscription pat _ _) =@@ -75,13 +75,7 @@   execState (astMap mapper e) extra   where     mapper =-      ASTMapper-        { mapOnExp = onExp,-          mapOnName = pure,-          mapOnQualName = pure,-          mapOnStructType = pure,-          mapOnPatType = pure-        }+      identityMapper {mapOnExp = onExp}     onExp e' = do       modify (<> expDefs e')       return e'@@ -233,6 +227,8 @@       atPosInTypeExp e1 pos `mplus` atPosInTypeExp e2 pos     TESum cs _ ->       msum $ map (`atPosInTypeExp` pos) $ concatMap snd cs+    TEDim _ t _ ->+      atPosInTypeExp t pos   where     inArg (TypeArgExpDim dim _) = inDim dim     inArg (TypeArgExpType e2) = atPosInTypeExp e2 pos@@ -251,6 +247,8 @@   msum $ map ((`atPosInPat` pos) . snd) fields atPosInPat (PatParens pat _) pos =   atPosInPat pat pos+atPosInPat (PatAttr _ pat _) pos =+  atPosInPat pat pos atPosInPat (PatAscription pat tdecl _) pos =   atPosInPat pat pos `mplus` atPosInTypeExp (declaredType tdecl) pos atPosInPat (PatConstr _ _ pats _) pos =@@ -288,13 +286,7 @@     Right _ -> Nothing   where     mapper =-      ASTMapper-        { mapOnExp = onExp,-          mapOnName = pure,-          mapOnQualName = pure,-          mapOnStructType = pure,-          mapOnPatType = pure-        }+      identityMapper {mapOnExp = onExp}     onExp e' =       case atPosInExp e' pos of         Just atpos -> Left atpos@@ -344,7 +336,7 @@     `mplus` join (atPosInTypeExp <$> valBindRetDecl vbind <*> pure pos)  atPosInTypeBind :: TypeBind -> Pos -> Maybe RawAtPos-atPosInTypeBind = atPosInTypeExp . declaredType . typeExp+atPosInTypeBind = atPosInTypeExp . typeExp  atPosInModBind :: ModBind -> Pos -> Maybe RawAtPos atPosInModBind (ModBind _ params sig e _ _) pos =

@@ -115,8 +115,10 @@   }   deriving (Show) --- | A binding from a name to its definition as a type.-data TypeBinding = TypeAbbr Liftedness [TypeParam] StructType+-- | A binding from a name to its definition as a type.  We allow a+-- return type here to support type abbreviations that hide some inner+-- sizes (these must necessarily be 'Lifted' or 'SizeLifted').+data TypeBinding = TypeAbbr Liftedness [TypeParam] StructRetType   deriving (Eq, Show)  -- | Type parameters, list of parameter types (optinally named), and

@@ -34,8 +34,11 @@     TypeArgExp (..),     PName (..),     ScalarTypeBase (..),+    RetTypeBase (..),     PatType,     StructType,+    StructRetType,+    PatRetType,     ValueType,     Diet (..),     TypeDeclBase (..),@@ -49,6 +52,7 @@      -- * Abstract syntax tree     AttrInfo (..),+    AttrAtom (..),     BinOp (..),     IdentBase (..),     Inclusiveness (..),@@ -131,12 +135,15 @@     Show (f PatType),     Show (f (PatType, [VName])),     Show (f (StructType, [VName])),+    Show (f (StructRetType, [VName])),     Show (f EntryPoint),     Show (f StructType),+    Show (f StructRetType),+    Show (f PatRetType),     Show (f (StructType, Maybe VName)),     Show (f (PName, StructType)),     Show (f (PName, StructType, Maybe VName)),-    Show (f (Aliasing, StructType)),+    Show (f (Aliasing, StructRetType)),     Show (f (M.Map VName VName)),     Show (f AppRes)   ) =>@@ -230,10 +237,16 @@ instance IsPrimValue Bool where   primValue = BoolValue +-- | The value of an 'AttrAtom'.+data AttrAtom vn+  = AtomName Name+  | AtomInt Integer+  deriving (Eq, Ord, Show)+ -- | The payload of an attribute.-data AttrInfo-  = AttrAtom Name-  | AttrComp Name [AttrInfo]+data AttrInfo vn+  = AttrAtom (AttrAtom vn) SrcLoc+  | AttrComp Name [AttrInfo vn] SrcLoc   deriving (Eq, Ord, Show)  -- | A type class for things that can be array dimensions.@@ -256,7 +269,9 @@   | -- | No known size - but still possibly given a unique name, so we     -- can recognise e.g. @type square [n] = [n][n]i32@ and make     -- @square []@ do the right thing.  If @Nothing@, then this is a-    -- name distinct from any other.+    -- name distinct from any other.  The type checker should _never_+    -- produce these - they are a (hopefully temporary) thing+    -- introduced by defunctorisation and monomorphisation.     AnyDim (Maybe vn)   deriving (Show) @@ -346,6 +361,23 @@ instance Ord PName where   _ <= _ = True +-- | Types that can appear to the right of a function arrow.  This+-- just means they can be existentially quantified.+data RetTypeBase dim as = RetType+  { retDims :: [VName],+    retType :: TypeBase dim as+  }+  deriving (Eq, Ord, Show)++instance Bitraversable RetTypeBase where+  bitraverse f g (RetType dims t) = RetType dims <$> bitraverse f g t++instance Bifunctor RetTypeBase where+  bimap = bimapDefault++instance Bifoldable RetTypeBase where+  bifoldMap = bifoldMapDefault+ -- | Types that can be elements of arrays.  This representation does -- allow arrays of records of functions, which is nonsensical, but it -- convolutes the code too much if we try to statically rule it out.@@ -356,7 +388,7 @@   | Sum (M.Map Name [TypeBase dim as])   | -- | The aliasing corresponds to the lexical     -- closure of the function.-    Arrow as PName (TypeBase dim as) (TypeBase dim as)+    Arrow as PName (TypeBase dim as) (RetTypeBase dim as)   deriving (Eq, Ord, Show)  instance Bitraversable ScalarTypeBase where@@ -435,6 +467,12 @@ -- | A value type contains full, manifest size information. type ValueType = TypeBase Int64 () +-- | The return type version of 'StructType'.+type StructRetType = RetTypeBase (DimDecl VName) ()++-- | The return type version of 'PatType'.+type PatRetType = RetTypeBase (DimDecl VName) Aliasing+ -- | A dimension declaration expression for use in a 'TypeExp'. data DimExp vn   = -- | The size of the dimension is this name, which@@ -466,6 +504,7 @@   | TEApply (TypeExp vn) (TypeArgExp vn) SrcLoc   | TEArrow (Maybe vn) (TypeExp vn) (TypeExp vn) SrcLoc   | TESum [(Name, [TypeExp vn])] SrcLoc+  | TEDim [vn] (TypeExp vn) SrcLoc   deriving (Show)  deriving instance Eq (TypeExp Name)@@ -485,6 +524,7 @@   locOf (TEApply _ _ loc) = locOf loc   locOf (TEArrow _ _ _ loc) = locOf loc   locOf (TESum _ loc) = locOf loc+  locOf (TEDim _ _ loc) = locOf loc  -- | A type argument expression passed to a type constructor. data TypeArgExp vn@@ -716,7 +756,7 @@       ( [TypeParamBase vn],         [PatBase f vn],         Maybe (TypeExp vn),-        f StructType,+        f StructRetType,         ExpBase f vn       )       (ExpBase f vn)@@ -803,7 +843,7 @@     -- Second arg is the row type of the rows of the array.     ArrayLit [ExpBase f vn] (f PatType) SrcLoc   | -- | An attribute applied to the following expression.-    Attr AttrInfo (ExpBase f vn) SrcLoc+    Attr (AttrInfo vn) (ExpBase f vn) SrcLoc   | Project Name (ExpBase f vn) (f PatType) SrcLoc   | -- | Numeric negation (ugly special case; Haskell did it first).     Negate (ExpBase f vn) SrcLoc@@ -821,7 +861,7 @@       [PatBase f vn]       (ExpBase f vn)       (Maybe (TypeExp vn))-      (f (Aliasing, StructType))+      (f (Aliasing, StructRetType))       SrcLoc   | -- | @+@; first two types are operands, third is result.     OpSection (QualName vn) (f PatType) SrcLoc@@ -831,7 +871,7 @@       (f PatType)       (ExpBase f vn)       (f (PName, StructType, Maybe VName), f (PName, StructType))-      (f PatType, f [VName])+      (f PatRetType, f [VName])       SrcLoc   | -- | @+2@; first type is operand, second is result.     OpSectionRight@@ -839,7 +879,7 @@       (f PatType)       (ExpBase f vn)       (f (PName, StructType), f (PName, StructType, Maybe VName))-      (f PatType)+      (f PatRetType)       SrcLoc   | -- | Field projection as a section: @(.x.y.z)@.     ProjectSection [Name] (f PatType) SrcLoc@@ -940,6 +980,7 @@   | PatAscription (PatBase f vn) (TypeDeclBase f vn) SrcLoc   | PatLit PatLit (f PatType) SrcLoc   | PatConstr Name (f PatType) [PatBase f vn] SrcLoc+  | PatAttr (AttrInfo vn) (PatBase f vn) SrcLoc  deriving instance Showable f vn => Show (PatBase f vn) @@ -956,6 +997,7 @@   locOf (PatAscription _ _ loc) = locOf loc   locOf (PatLit _ _ loc) = locOf loc   locOf (PatConstr _ _ _ loc) = locOf loc+  locOf (PatAttr _ _ loc) = locOf loc  -- | Documentation strings, including source location. data DocComment = DocComment String SrcLoc@@ -999,12 +1041,12 @@     valBindEntryPoint :: Maybe (f EntryPoint),     valBindName :: vn,     valBindRetDecl :: Maybe (TypeExp vn),-    valBindRetType :: f (StructType, [VName]),+    valBindRetType :: f (StructRetType, [VName]),     valBindTypeParams :: [TypeParamBase vn],     valBindParams :: [PatBase f vn],     valBindBody :: ExpBase f vn,     valBindDoc :: Maybe DocComment,-    valBindAttrs :: [AttrInfo],+    valBindAttrs :: [AttrInfo vn],     valBindLocation :: SrcLoc   } @@ -1018,7 +1060,8 @@   { typeAlias :: vn,     typeLiftedness :: Liftedness,     typeParams :: [TypeParamBase vn],-    typeExp :: TypeDeclBase f vn,+    typeExp :: TypeExp vn,+    typeElab :: f StructRetType,     typeDoc :: Maybe DocComment,     typeBindLocation :: SrcLoc   }

@@ -41,7 +41,9 @@     mapOnName :: VName -> m VName,     mapOnQualName :: QualName VName -> m (QualName VName),     mapOnStructType :: StructType -> m StructType,-    mapOnPatType :: PatType -> m PatType+    mapOnPatType :: PatType -> m PatType,+    mapOnStructRetType :: StructRetType -> m StructRetType,+    mapOnPatRetType :: PatRetType -> m PatRetType   }  -- | An 'ASTMapper' that just leaves its input unchanged.@@ -52,7 +54,9 @@       mapOnName = return,       mapOnQualName = return,       mapOnStructType = return,-      mapOnPatType = return+      mapOnPatType = return,+      mapOnStructRetType = return,+      mapOnPatRetType = return     }  -- | The class of things that we can map an 'ASTMapper' across.@@ -80,7 +84,7 @@     LetFun <$> mapOnName tv name       <*> ( (,,,,) <$> mapM (astMap tv) fparams <*> mapM (astMap tv) params               <*> traverse (astMap tv) ret-              <*> traverse (mapOnStructType tv) t+              <*> traverse (mapOnStructRetType tv) t               <*> mapOnExp tv e           )       <*> mapOnExp tv body@@ -161,13 +165,13 @@     Lambda <$> mapM (astMap tv) params       <*> mapOnExp tv body       <*> traverse (astMap tv) ret-      <*> traverse (traverse $ mapOnStructType tv) t+      <*> traverse (traverse $ mapOnStructRetType tv) t       <*> pure loc   astMap tv (OpSection name t loc) =     OpSection <$> mapOnQualName tv name       <*> traverse (mapOnPatType tv) t       <*> pure loc-  astMap tv (OpSectionLeft name t arg (Info (pa, t1a, argext), Info (pb, t1b)) (t2, retext) loc) =+  astMap tv (OpSectionLeft name t arg (Info (pa, t1a, argext), Info (pb, t1b)) (ret, retext) loc) =     OpSectionLeft <$> mapOnQualName tv name       <*> traverse (mapOnPatType tv) t       <*> mapOnExp tv arg@@ -175,7 +179,7 @@               <$> (Info <$> ((pa,,) <$> mapOnStructType tv t1a <*> pure argext))               <*> (Info <$> ((pb,) <$> mapOnStructType tv t1b))           )-      <*> ((,) <$> traverse (mapOnPatType tv) t2 <*> pure retext)+      <*> ((,) <$> traverse (mapOnPatRetType tv) ret <*> traverse (mapM (mapOnName tv)) retext)       <*> pure loc   astMap tv (OpSectionRight name t arg (Info (pa, t1a), Info (pb, t1b, argext)) t2 loc) =     OpSectionRight <$> mapOnQualName tv name@@ -185,7 +189,7 @@               <$> (Info <$> ((pa,) <$> mapOnStructType tv t1a))               <*> (Info <$> ((pb,,) <$> mapOnStructType tv t1b <*> pure argext))           )-      <*> traverse (mapOnPatType tv) t2+      <*> traverse (mapOnPatRetType tv) t2       <*> pure loc   astMap tv (ProjectSection fields t loc) =     ProjectSection fields <$> traverse (mapOnPatType tv) t <*> pure loc@@ -219,6 +223,8 @@     TEArrow v <$> astMap tv t1 <*> astMap tv t2 <*> pure loc   astMap tv (TESum cs loc) =     TESum <$> traverse (traverse $ astMap tv) cs <*> pure loc+  astMap tv (TEDim dims t loc) =+    TEDim dims <$> astMap tv t <*> pure loc  instance ASTMappable (TypeArgExp VName) where   astMap tv (TypeArgExpDim dim loc) =@@ -273,8 +279,9 @@ traverseScalarType f g h (Record fs) = Record <$> traverse (traverseType f g h) fs traverseScalarType f g h (TypeVar als u t args) =   TypeVar <$> h als <*> pure u <*> f t <*> traverse (traverseTypeArg f g) args-traverseScalarType f g h (Arrow als v t1 t2) =-  Arrow <$> h als <*> pure v <*> traverseType f g h t1 <*> traverseType f g h t2+traverseScalarType f g h (Arrow als v t1 (RetType dims t2)) =+  Arrow <$> h als <*> pure v <*> traverseType f g h t1+    <*> (RetType dims <$> traverseType f g h t2) traverseScalarType f g h (Sum cs) =   Sum <$> (traverse . traverse) (traverseType f g h) cs @@ -309,6 +316,12 @@     where       f = fmap typeNameFromQualName . mapOnQualName tv . qualNameFromTypeName +instance ASTMappable StructRetType where+  astMap tv (RetType ext t) = RetType ext <$> astMap tv t++instance ASTMappable PatRetType where+  astMap tv (RetType ext t) = RetType ext <$> astMap tv t+ instance ASTMappable (TypeDeclBase Info VName) where   astMap tv (TypeDecl dt (Info et)) =     TypeDecl <$> astMap tv dt <*> (Info <$> mapOnStructType tv et)@@ -338,6 +351,8 @@     PatLit v <$> (Info <$> mapOnPatType tv t) <*> pure loc   astMap tv (PatConstr n (Info t) ps loc) =     PatConstr n <$> (Info <$> mapOnPatType tv t) <*> mapM (astMap tv) ps <*> pure loc+  astMap tv (PatAttr attr p loc) =+    PatAttr attr <$> astMap tv p <*> pure loc  instance ASTMappable (FieldBase Info VName) where   astMap tv (RecordFieldExplicit name e loc) =@@ -392,6 +407,7 @@   PatAscription (barePat pat) (TypeDecl t NoInfo) loc barePat (PatLit v _ loc) = PatLit v NoInfo loc barePat (PatConstr c _ ps loc) = PatConstr c NoInfo (map barePat ps) loc+barePat (PatAttr attr p loc) = PatAttr attr (barePat p) loc  bareDimIndex :: DimIndexBase Info VName -> DimIndexBase NoInfo VName bareDimIndex (DimFix e) =

@@ -19,7 +19,7 @@  import Control.Monad.Except import Control.Monad.Writer hiding (Sum)-import Data.Bifunctor (second)+import Data.Bifunctor (first, second) import Data.Char (isAlpha, isAlphaNum) import Data.Either import Data.List (isPrefixOf)@@ -130,7 +130,7 @@     intrinsicsModule = Env mempty initialTypeTable mempty mempty intrinsicsNameMap      addIntrinsicT (name, IntrinsicType l ps t) =-      Just (name, TypeAbbr l ps t)+      Just (name, TypeAbbr l ps $ RetType [] t)     addIntrinsicT _ =       Nothing @@ -165,7 +165,7 @@      f (ValDec vb) =       check Term (valBindName vb) (srclocOf vb)-    f (TypeDec (TypeBind name _ _ _ _ loc)) =+    f (TypeDec (TypeBind name _ _ _ _ _ loc)) =       check Type name loc     f (SigDec (SigBind name _ _ loc)) =       check Signature name loc@@ -189,15 +189,16 @@       mempty         { envTypeTable =             M.singleton v $-              TypeAbbr l [] $-                Scalar $ TypeVar () Nonunique (typeName v) []+              TypeAbbr l [] . RetType [] . Scalar $+                TypeVar () Nonunique (typeName v) []         } -emptyDimParam :: StructType -> Bool-emptyDimParam = isNothing . traverseDims onDim-  where-    onDim _ pos (AnyDim _) | pos `elem` [PosImmediate, PosParam] = Nothing-    onDim _ _ d = Just d+checkTypeDecl ::+  TypeDeclBase NoInfo Name ->+  TypeM ([VName], TypeDeclBase Info VName, Liftedness)+checkTypeDecl (TypeDecl te NoInfo) = do+  (te', svars, RetType dims st, l) <- checkTypeExp te+  pure (svars ++ dims, TypeDecl te' $ Info st, l)  -- In this function, after the recursion, we add the Env of the -- current Spec *after* the one that is returned from the recursive@@ -212,20 +213,14 @@     name' <- checkName Term name loc     (tparams', vtype') <-       checkTypeParams tparams $ \tparams' -> bindingTypeParams tparams' $ do-        (vtype', _) <- checkTypeDecl vtype-        return (tparams', vtype')+        (ext, vtype', _) <- checkTypeDecl vtype -    when (emptyDimParam $ unInfo $ expandedType vtype') $-      typeError loc mempty $-        "All function parameters must have non-anonymous sizes."-          </> "Hint: add size parameters to" <+> pquote (pprName name') <> "."+        unless (null ext) $+          typeError loc mempty $+            "All function parameters must have non-anonymous sizes."+              </> "Hint: add size parameters to" <+> pquote (pprName name') <> "." -    let (params, _) = unfoldFunType $ unInfo $ expandedType vtype'-    when (null params && any isSizeParam tparams) $-      typeError-        loc-        mempty-        "Size parameters are only allowed on bindings that also have value parameters."+        return (tparams', vtype')      let binding = BoundV tparams' $ unInfo $ expandedType vtype'         valenv =@@ -258,10 +253,9 @@                   M.singleton (Type, name) $ qualName name',                 envTypeTable =                   M.singleton name' $-                    TypeAbbr l ps' $-                      Scalar $-                        TypeVar () Nonunique (typeName name') $-                          map typeParamToArg ps'+                    TypeAbbr l ps' . RetType [] . Scalar $+                      TypeVar () Nonunique (typeName name') $+                        map typeParamToArg ps'               }       (abstypes, env, specs') <- localEnv tenv $ checkSpecs specs       return@@ -317,7 +311,9 @@ checkSigExp (SigWith s (TypeRef tname ps td trloc) loc) = do   (abs, s_abs, s_env, s') <- checkSigExpToEnv s   checkTypeParams ps $ \ps' -> do-    (td', _) <- bindingTypeParams ps' $ checkTypeDecl td+    (ext, td', _) <- bindingTypeParams ps' $ checkTypeDecl td+    unless (null ext) $+      typeError td' mempty "Anonymous dimensions are not allowed here."     (tname', s_abs', s_env') <- refineEnv loc s_abs s_env tname ps' $ unInfo $ expandedType td'     return (abs, MTy s_abs' $ ModEnv s_env', SigWith s' (TypeRef tname' ps' td' trloc) loc) checkSigExp (SigArrow maybe_pname e1 e2 loc) = do@@ -532,7 +528,7 @@      f (ValSpec name _ _ _ loc) =       check Term name loc-    f (TypeAbbrSpec (TypeBind name _ _ _ _ loc)) =+    f (TypeAbbrSpec (TypeBind name _ _ _ _ _ loc)) =       check Type name loc     f (TypeSpec _ name _ _ loc) =       check Type name loc@@ -544,11 +540,12 @@ checkTypeBind ::   TypeBindBase NoInfo Name ->   TypeM (Env, TypeBindBase Info VName)-checkTypeBind (TypeBind name l tps td doc loc) =+checkTypeBind (TypeBind name l tps te NoInfo doc loc) =   checkTypeParams tps $ \tps' -> do-    (td', l') <- bindingTypeParams tps' $ checkTypeDecl td+    (te', svars, RetType dims t, l') <- bindingTypeParams tps' $ checkTypeExp te+    let elab_t = RetType (svars ++ dims) t -    let used_dims = typeDimNames $ unInfo $ expandedType td'+    let used_dims = typeDimNames t     case filter ((`S.notMember` used_dims) . typeParamName) $       filter isSizeParam tps' of       [] -> return ()@@ -568,9 +565,9 @@             "Non-size-lifted type abbreviations may not contain size-lifted types."               </> "Hint: consider using 'type~'."       (Unlifted, _)-        | emptyDimParam $ unInfo $ expandedType td' ->+        | not $ null $ svars ++ dims ->           typeError loc mempty $-            "Non-lifted type abbreviations may not use anonymous sizes in their definition."+            "Non-lifted type abbreviations may not use existential sizes in their definition."               </> "Hint: use 'type~' or add size parameters to"               <+> pquote (pprName name) <> "."       _ -> return ()@@ -580,19 +577,24 @@       return         ( mempty             { envTypeTable =-                M.singleton name' $ TypeAbbr l tps' $ unInfo $ expandedType td',+                M.singleton name' $ TypeAbbr l tps' elab_t,               envNameMap =                 M.singleton (Type, name) $ qualName name'             },-          TypeBind name' l tps' td' doc loc+          TypeBind name' l tps' te' (Info elab_t) doc loc         ) -entryPoint :: [Pat] -> Maybe (TypeExp VName) -> StructType -> EntryPoint-entryPoint params orig_ret_te orig_ret =+entryPoint :: [Pat] -> Maybe (TypeExp VName) -> StructRetType -> EntryPoint+entryPoint params orig_ret_te (RetType ret orig_ret) =   EntryPoint (map patternEntry params ++ more_params) rettype'   where-    (more_params, rettype') = onRetType orig_ret_te orig_ret+    (more_params, rettype') = onRetType orig_ret_te $ first extToAny orig_ret +    -- Since the entry point type is not a RetType but just a plain+    -- StructType, we have to remove any existentially bound sizes.+    extToAny (NamedDim v) | qualLeaf v `elem` ret = AnyDim Nothing+    extToAny d = d+     patternEntry (PatParens p _) =       patternEntry p     patternEntry (PatAscription p tdecl _) =@@ -608,11 +610,10 @@      pname (Named v) = baseName v     pname Unnamed = "_"--    onRetType (Just (TEArrow p t1_te t2_te _)) (Scalar (Arrow _ _ t1 t2)) =+    onRetType (Just (TEArrow p t1_te t2_te _)) (Scalar (Arrow _ _ t1 (RetType _ t2))) =       let (xs, y) = onRetType (Just t2_te) t2        in (EntryParam (maybe "_" baseName p) (EntryType t1 (Just t1_te)) : xs, y)-    onRetType _ (Scalar (Arrow _ p t1 t2)) =+    onRetType _ (Scalar (Arrow _ p t1 (RetType _ t2))) =       let (xs, y) = onRetType Nothing t2        in (EntryParam (pname p) (EntryType t1 Nothing) : xs, y)     onRetType te t =@@ -632,10 +633,10 @@     typeError loc mempty $       withIndexLink "nested-entry" "Entry points may not be declared inside modules." -  (fname', tparams', params', maybe_tdecl', rettype, retext, body') <-+  (fname', tparams', params', maybe_tdecl', rettype@(RetType _ rettype_t), retext, body') <-     checkFunDef (fname, maybe_tdecl, tparams, params, body, loc) -  let (rettype_params, rettype') = unfoldFunType rettype+  let (rettype_params, rettype') = unfoldFunType rettype_t       entry' = Info (entryPoint params' maybe_tdecl' rettype) <$ entry    case entry' of@@ -659,14 +660,15 @@           "Entry point parameter\n"             </> indent 2 (ppr p)             </> "\nwill have an opaque type, so the entry point will likely not be callable."-      | nastyReturnType maybe_tdecl' rettype ->+      | nastyReturnType maybe_tdecl' rettype_t ->         warn loc $           "Entry point return type\n"             </> indent 2 (ppr rettype)             </> "\nwill have an opaque type, so the result will likely not be usable."     _ -> return () -  let vb = ValBind entry' fname' maybe_tdecl' (Info (rettype, retext)) tparams' params' body' doc attrs loc+  attrs' <- mapM checkAttr attrs+  let vb = ValBind entry' fname' maybe_tdecl' (Info (rettype, retext)) tparams' params' body' doc attrs' loc   return     ( mempty         { envVtable =@@ -683,9 +685,9 @@ nastyType _ = True  nastyReturnType :: Monoid als => Maybe (TypeExp VName) -> TypeBase dim als -> Bool-nastyReturnType Nothing (Scalar (Arrow _ _ t1 t2)) =+nastyReturnType Nothing (Scalar (Arrow _ _ t1 (RetType _ t2))) =   nastyType t1 || nastyReturnType Nothing t2-nastyReturnType (Just (TEArrow _ te1 te2 _)) (Scalar (Arrow _ _ t1 t2)) =+nastyReturnType (Just (TEArrow _ te1 te2 _)) (Scalar (Arrow _ _ t1 (RetType _ t2))) =   (not (niceTypeExp te1) && nastyType t1)     || nastyReturnType (Just te2) t2 nastyReturnType (Just te) _

@@ -54,6 +54,7 @@ patternToMatch (Id _ (Info t) _) = MatchWild $ toStruct t patternToMatch (Wildcard (Info t) _) = MatchWild $ toStruct t patternToMatch (PatParens p _) = patternToMatch p+patternToMatch (PatAttr _ p _) = patternToMatch p patternToMatch (PatAscription p _ _) = patternToMatch p patternToMatch (PatLit l (Info t) _) =   MatchConstr (ConstrLit l) [] $ toStruct t

@@ -45,12 +45,14 @@     }   where     subT name (TypeAbbr l _ _)-      | Just (Subst ps t) <- substs name = TypeAbbr l ps t-    subT _ (TypeAbbr l ps t) = TypeAbbr l ps $ applySubst substs t+      | Just (Subst ps rt) <- substs name = TypeAbbr l ps rt+    subT _ (TypeAbbr l ps (RetType dims t)) =+      TypeAbbr l ps $ applySubst substs $ RetType dims t  substituteTypesInBoundV :: TypeSubs -> BoundV -> BoundV substituteTypesInBoundV substs (BoundV tps t) =-  BoundV tps (applySubst substs t)+  let RetType dims t' = applySubst substs $ RetType [] t+   in BoundV (tps ++ map (`TypeParamDim` mempty) dims) t'  -- | All names defined anywhere in the 'Env'. allNamesInEnv :: Env -> S.Set VName@@ -128,8 +130,8 @@             (substituteInMod mod)             (substituteInMTy substs mty) -        substituteInTypeBinding (TypeAbbr l ps t) =-          TypeAbbr l (map substituteInTypeParam ps) $ substituteInType t+        substituteInTypeBinding (TypeAbbr l ps (RetType dims t)) =+          TypeAbbr l (map substituteInTypeParam ps) $ RetType dims $ substituteInType t          substituteInTypeParam (TypeParamDim p loc) =           TypeParamDim (substitute p) loc@@ -149,8 +151,8 @@           Scalar $ Sum $ (fmap . fmap) substituteInType ts         substituteInType (Array () u t shape) =           arrayOf (substituteInType $ Scalar t) (substituteInShape shape) u-        substituteInType (Scalar (Arrow als v t1 t2)) =-          Scalar $ Arrow als v (substituteInType t1) (substituteInType t2)+        substituteInType (Scalar (Arrow als v t1 (RetType dims t2))) =+          Scalar $ Arrow als v (substituteInType t1) $ RetType dims $ substituteInType t2          substituteInShape (ShapeDecl ds) =           ShapeDecl $ map substituteInDim ds@@ -191,7 +193,7 @@   StructType ->   TypeM (QualName VName, TySet, Env) refineEnv loc tset env tname ps t-  | Just (tname', TypeAbbr _ cur_ps (Scalar (TypeVar () _ (TypeName qs v) _))) <-+  | Just (tname', TypeAbbr _ cur_ps (RetType _ (Scalar (TypeVar () _ (TypeName qs v) _)))) <-       findTypeDef tname (ModEnv env),     QualName (qualQuals tname') v `M.member` tset =     if paramsMatch cur_ps ps@@ -200,7 +202,12 @@           ( tname',             QualName qs v `M.delete` tset,             substituteTypesInEnv-              (flip M.lookup $ M.fromList [(qualLeaf tname', Subst cur_ps t), (v, Subst ps t)])+              ( flip M.lookup $+                  M.fromList+                    [ (qualLeaf tname', Subst cur_ps $ RetType [] t),+                      (v, Subst ps $ RetType [] t)+                    ]+              )               env           )       else@@ -252,35 +259,33 @@           zip             (map (fmap baseName . fst) $ M.toList mod_abs)             (M.toList mod_abs)-  fmap M.fromList $-    forM (M.toList sig_abs) $ \(name, name_l) ->-      case findTypeDef (fmap baseName name) mod of-        Just (name', TypeAbbr mod_l ps t)-          | mod_l > name_l ->-            mismatchedLiftedness-              name_l-              (map qualLeaf $ M.keys mod_abs)-              (qualLeaf name)-              (mod_l, ps, t)-          | name_l < SizeLifted,-            emptyDims t ->-            anonymousSizes-              (map qualLeaf $ M.keys mod_abs)-              (qualLeaf name)-              (mod_l, ps, t)-          | Just (abs_name, _) <- M.lookup (fmap baseName name) abs_mapping ->-            return (qualLeaf name, (abs_name, TypeAbbr name_l ps t))-          | otherwise ->-            return (qualLeaf name, (name', TypeAbbr name_l ps t))-        _ ->-          missingType loc $ fmap baseName name+  fmap M.fromList . forM (M.toList sig_abs) $ \(name, name_l) ->+    case findTypeDef (fmap baseName name) mod of+      Just (name', TypeAbbr mod_l ps t)+        | mod_l > name_l ->+          mismatchedLiftedness+            name_l+            (map qualLeaf $ M.keys mod_abs)+            (qualLeaf name)+            (mod_l, ps, t)+        | name_l < SizeLifted,+          not $ null $ retDims t ->+          anonymousSizes+            (map qualLeaf $ M.keys mod_abs)+            (qualLeaf name)+            (mod_l, ps, t)+        | Just (abs_name, _) <- M.lookup (fmap baseName name) abs_mapping ->+          return (qualLeaf name, (abs_name, TypeAbbr name_l ps t))+        | otherwise ->+          return (qualLeaf name, (name', TypeAbbr name_l ps t))+      _ ->+        missingType loc $ fmap baseName name   where     mismatchedLiftedness name_l abs name mod_t =-      Left $-        TypeError loc mempty $-          "Module defines"-            </> indent 2 (ppTypeAbbr abs name mod_t)-            </> "but module type requires" <+> text what <> "."+      Left . TypeError loc mempty $+        "Module defines"+          </> indent 2 (ppTypeAbbr abs name mod_t)+          </> "but module type requires" <+> text what <> "."       where         what = case name_l of           Unlifted -> "a non-lifted type"@@ -294,12 +299,6 @@             </> indent 2 (ppTypeAbbr abs name mod_t)             </> "which contains anonymous sizes, but module type requires non-lifted type." -    emptyDims :: StructType -> Bool-    emptyDims = isNothing . traverseDims onDim-      where-        onDim _ PosImmediate (AnyDim _) = Nothing-        onDim _ _ d = Just d- resolveMTyNames ::   MTy ->   MTy ->@@ -361,8 +360,8 @@   SrcLoc ->   [VName] ->   VName ->-  (Liftedness, [TypeParam], StructType) ->-  (Liftedness, [TypeParam], StructType) ->+  (Liftedness, [TypeParam], StructRetType) ->+  (Liftedness, [TypeParam], StructRetType) ->   Either TypeError b mismatchedType loc abs name spec_t env_t =   Left $@@ -372,8 +371,8 @@         </> "but module type requires"         </> indent 2 (ppTypeAbbr abs name spec_t) -ppTypeAbbr :: [VName] -> VName -> (Liftedness, [TypeParam], StructType) -> Doc-ppTypeAbbr abs name (l, ps, Scalar (TypeVar () _ tn args))+ppTypeAbbr :: [VName] -> VName -> (Liftedness, [TypeParam], StructRetType) -> Doc+ppTypeAbbr abs name (l, ps, RetType [] (Scalar (TypeVar () _ tn args)))   | typeLeaf tn `elem` abs,     map typeParamToArg ps == args =     "type" <> ppr l <+> pprName name@@ -400,7 +399,7 @@     orig_mty_sig   where     matchMTys' ::-      M.Map VName (Subst StructType) ->+      M.Map VName (Subst StructRetType) ->       MTy ->       MTy ->       SrcLoc ->@@ -431,7 +430,7 @@       return (substs <> abs_name_substs)      matchMods ::-      M.Map VName (Subst StructType) ->+      M.Map VName (Subst StructRetType) ->       Mod ->       Mod ->       SrcLoc ->@@ -464,7 +463,7 @@         return (pmod_substs <> mod_substs <> abs_name_substs)      matchEnvs ::-      M.Map VName (Subst StructType) ->+      M.Map VName (Subst StructRetType) ->       Env ->       Env ->       SrcLoc ->@@ -478,12 +477,8 @@        -- Check that all type abbreviations are correctly defined.       abbr_name_substs <- fmap M.fromList $-        forM-          ( filter (isVisible . fst) $-              M.toList $-                envTypeTable sig-          )-          $ \(name, TypeAbbr spec_l spec_ps spec_t) ->+        forM (filter (isVisible . fst) $ M.toList $ envTypeTable sig) $+          \(name, TypeAbbr spec_l spec_ps spec_t) ->             case findBinding envTypeTable Type (baseName name) env of               Just (name', TypeAbbr l ps t) ->                 matchTypeAbbr loc abs_subst_to_type name spec_l spec_ps spec_t name' l ps t@@ -511,15 +506,15 @@      matchTypeAbbr ::       SrcLoc ->-      M.Map VName (Subst StructType) ->+      M.Map VName (Subst StructRetType) ->       VName ->       Liftedness ->       [TypeParam] ->-      StructType ->+      StructRetType ->       VName ->       Liftedness ->       [TypeParam] ->-      StructType ->+      StructRetType ->       Either TypeError (VName, VName)     matchTypeAbbr loc abs_subst_to_type spec_name spec_l spec_ps spec_t name l ps t = do       -- We have to create substitutions for the type parameters, too.@@ -531,16 +526,15 @@       -- if we have a value of an abstract type 't [n]', then there is       -- an array of size 'n' somewhere inside.       when (M.member spec_name abs_subst_to_type) $-        case S.toList (mustBeExplicitInType t) `intersect` map typeParamName ps of+        case S.toList (mustBeExplicitInType (retType t)) `intersect` map typeParamName ps of           [] -> return ()           d : _ ->-            Left $-              TypeError loc mempty $-                "Type"-                  </> indent 2 (ppTypeAbbr [] name (l, ps, t))-                  </> textwrap "cannot be made abstract because size parameter"-                  <+/> pquote (pprName d)-                  <+/> textwrap "is not used as an array size in the definition."+            Left . TypeError loc mempty $+              "Type"+                </> indent 2 (ppTypeAbbr [] name (l, ps, t))+                </> textwrap "cannot be made abstract because size parameter"+                <+/> pquote (pprName d)+                <+/> textwrap "is not used as an array size in the definition."        let spec_t' = applySubst (`M.lookup` (param_substs <> abs_subst_to_type)) spec_t       if spec_t' == t@@ -559,7 +553,7 @@       pure $ M.singleton x $ SizeSubst $ NamedDim $ qualName y     matchTypeParam _ (TypeParamType spec_l x _) (TypeParamType l y _)       | spec_l <= l =-        pure . M.singleton x . Subst [] $+        pure . M.singleton x . Subst [] . RetType [] $           Scalar $ TypeVar () Nonunique (typeName y) []     matchTypeParam nomatch _ _ =       nomatch

@@ -30,6 +30,7 @@     aNote,     MonadTypeChecker (..),     checkName,+    checkAttr,     badOnLeft,     module Language.Futhark.Warnings,     Env (..),@@ -50,6 +51,7 @@     Namespace (..),     intrinsicsNameMap,     topLevelNameMap,+    mkTypeVarName,   ) where @@ -162,7 +164,8 @@  data TypeState = TypeState   { stateNameSource :: VNameSource,-    stateWarnings :: Warnings+    stateWarnings :: Warnings,+    stateCounter :: Int   }  -- | The type checker runs in this monad.@@ -203,10 +206,10 @@   (Warnings, Either TypeError (a, VNameSource)) runTypeM env imports fpath src (TypeM m) = do   let ctx = Context env imports fpath True-      s = TypeState src mempty+      s = TypeState src mempty 0   case runExcept $ runStateT (runReaderT m ctx) s of     Left (ws, e) -> (ws, Left e)-    Right (x, TypeState src' ws) -> (ws, Right (x, src'))+    Right (x, TypeState src' ws _) -> (ws, Right (x, src'))  -- | Retrieve the current 'Env'. askEnv :: TypeM Env@@ -253,6 +256,12 @@   let env' = env <> contextEnv ctx    in ctx {contextEnv = env'} +incCounter :: TypeM Int+incCounter = do+  s <- get+  put s {stateCounter = stateCounter s + 1}+  return $ stateCounter s+ -- | Monads that support type checking.  The reason we have this -- internal interface is because we use distinct monads for checking -- expressions and declarations.@@ -261,13 +270,14 @@    newName :: VName -> m VName   newID :: Name -> m VName+  newTypeName :: Name -> m VName    bindNameMap :: NameMap -> m a -> m a   bindVal :: VName -> BoundV -> m a -> m a    checkQualName :: Namespace -> QualName Name -> SrcLoc -> m (QualName VName) -  lookupType :: SrcLoc -> QualName Name -> m (QualName VName, [TypeParam], StructType, Liftedness)+  lookupType :: SrcLoc -> QualName Name -> m (QualName VName, [TypeParam], StructRetType, Liftedness)   lookupMod :: SrcLoc -> QualName Name -> m (QualName VName, Mod)   lookupVar :: SrcLoc -> QualName Name -> m (QualName VName, PatType) @@ -310,6 +320,10 @@    newID s = newName $ VName s 0 +  newTypeName name = do+    i <- incCounter+    newID $ mkTypeVarName name i+   bindNameMap m = local $ \ctx ->     let env = contextEnv ctx      in ctx {contextEnv = env {envNameMap = m <> envNameMap env}}@@ -329,7 +343,8 @@     (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc     case M.lookup name $ envTypeTable scope of       Nothing -> unknownType loc qn-      Just (TypeAbbr l ps def) -> return (qn', ps, qualifyTypeVars outer_env mempty qs def, l)+      Just (TypeAbbr l ps (RetType dims def)) ->+        return (qn', ps, RetType dims $ qualifyTypeVars outer_env mempty qs def, l)    lookupMod loc qn = do     (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Term qn loc@@ -346,10 +361,10 @@         | "_" `isPrefixOf` baseString name -> underscoreUse loc qn         | otherwise ->           case getType t of-            Left {} ->+            Nothing ->               typeError loc mempty $                 "Attempt to use function" <+> pprName name <+> "as value."-            Right t' ->+            Just t' ->               return                 ( qn',                   fromStruct $@@ -358,18 +373,10 @@    typeError loc notes s = throwError $ TypeError (srclocOf loc) notes s --- | Extract from a type either a function type comprising a list of--- parameter types and a return type, or a first-order type.-getType ::-  TypeBase dim as ->-  Either-    ([(PName, TypeBase dim as)], TypeBase dim as)-    (TypeBase dim as)-getType (Scalar (Arrow _ v t1 t2)) =-  case getType t2 of-    Left (ps, r) -> Left ((v, t1) : ps, r)-    Right _ -> Left ([(v, t1)], t2)-getType t = Right t+-- | Extract from a type a first-order type.+getType :: TypeBase dim as -> Maybe (TypeBase dim as)+getType (Scalar Arrow {}) = Nothing+getType t = Just t  checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TypeM (Env, QualName VName) checkQualNameWithEnv space qn@(QualName quals name) loc = do@@ -420,8 +427,8 @@       Record $ M.map (onType except) m     onScalar except (Sum m) =       Sum $ M.map (map $ onType except) m-    onScalar except (Arrow as p t1 t2) =-      Arrow as p (onType except' t1) (onType except' t2)+    onScalar except (Arrow as p t1 (RetType dims t2)) =+      Arrow as p (onType except' t1) $ RetType dims (onType except' t2)       where         except' = case p of           Named p' -> S.insert p' except@@ -451,7 +458,7 @@       name `M.member` envVtable env         || isJust (find matches $ M.elems (envTypeTable env))       where-        matches (TypeAbbr _ _ (Scalar (TypeVar _ _ (TypeName x_qs name') _))) =+        matches (TypeAbbr _ _ (RetType _ (Scalar (TypeVar _ _ (TypeName x_qs name') _)))) =           null x_qs && name == name'         matches _ = False     reachable (q : qs') name env@@ -512,3 +519,22 @@               [minBound .. (maxBound :: BinOp)]         fun_names = S.fromList $ map nameFromString ["shape"]     available _ = False++-- | Construct the name of a new type variable given a base+-- description and a tag number (note that this is distinct from+-- actually constructing a VName; the tag here is intended for human+-- consumption but the machine does not care).+mkTypeVarName :: Name -> Int -> Name+mkTypeVarName desc i =+  desc <> nameFromString (mapMaybe subscript (show i))+  where+    subscript = flip lookup $ zip "0123456789" "₀₁₂₃₄₅₆₇₈₉"++-- | Type-check an attribute.+checkAttr :: MonadTypeChecker m => AttrInfo Name -> m (AttrInfo VName)+checkAttr (AttrComp f attrs loc) =+  AttrComp f <$> mapM checkAttr attrs <*> pure loc+checkAttr (AttrAtom (AtomName v) loc) =+  pure $ AttrAtom (AtomName v) loc+checkAttr (AttrAtom (AtomInt x) loc) =+  pure $ AttrAtom (AtomInt x) loc

@@ -1,3291 +1,1740 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TupleSections #-}---- | Facilities for type-checking Futhark terms.  Checking a term--- requires a little more context to track uniqueness and such.------ Type inference is implemented through a variation of--- Hindley-Milner.  The main complication is supporting the rich--- number of built-in language constructs, as well as uniqueness--- types.  This is mostly done in an ad hoc way, and many programs--- will require the programmer to fall back on type annotations.-module Language.Futhark.TypeChecker.Terms-  ( checkOneExp,-    checkFunDef,-  )-where--import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State-import Data.Bifunctor-import Data.Bitraversable-import Data.Char (isAscii)-import Data.Either-import Data.List (find, foldl', isPrefixOf, sort)-import qualified Data.List.NonEmpty as NE-import qualified Data.Map.Strict as M-import Data.Maybe-import qualified Data.Set as S-import Futhark.IR.Primitive (intByteSize)-import Futhark.Util (nubOrd)-import Futhark.Util.Pretty hiding (bool, group, space)-import Language.Futhark-import Language.Futhark.Semantic (includeToFilePath)-import Language.Futhark.Traversals-import Language.Futhark.TypeChecker.Match-import Language.Futhark.TypeChecker.Monad hiding (BoundV)-import qualified Language.Futhark.TypeChecker.Monad as TypeM-import Language.Futhark.TypeChecker.Types hiding (checkTypeDecl)-import qualified Language.Futhark.TypeChecker.Types as Types-import Language.Futhark.TypeChecker.Unify hiding (Usage)-import Prelude hiding (mod)----- Uniqueness--data Usage-  = Consumed SrcLoc-  | Observed SrcLoc-  deriving (Eq, Ord, Show)--type Names = S.Set VName---- | The consumption set is a Maybe so we can distinguish whether a--- consumption took place, but the variable went out of scope since,--- or no consumption at all took place.-data Occurence = Occurence-  { observed :: Names,-    consumed :: Maybe Names,-    location :: SrcLoc-  }-  deriving (Eq, Show)--instance Located Occurence where-  locOf = locOf . location--observation :: Aliasing -> SrcLoc -> Occurence-observation = flip Occurence Nothing . S.map aliasVar--consumption :: Aliasing -> SrcLoc -> Occurence-consumption = Occurence S.empty . Just . S.map aliasVar---- | A null occurence is one that we can remove without affecting--- anything.-nullOccurence :: Occurence -> Bool-nullOccurence occ = S.null (observed occ) && isNothing (consumed occ)---- | A seminull occurence is one that does not contain references to--- any variables in scope.  The big difference is that a seminull--- occurence may denote a consumption, as long as the array that was--- consumed is now out of scope.-seminullOccurence :: Occurence -> Bool-seminullOccurence occ = S.null (observed occ) && maybe True S.null (consumed occ)--type Occurences = [Occurence]--type UsageMap = M.Map VName [Usage]--usageMap :: Occurences -> UsageMap-usageMap = foldl comb M.empty-  where-    comb m (Occurence obs cons loc) =-      let m' = S.foldl' (ins $ Observed loc) m obs-       in S.foldl' (ins $ Consumed loc) m' $ fromMaybe mempty cons-    ins v m k = M.insertWith (++) k [v] m--combineOccurences :: VName -> Usage -> Usage -> TermTypeM Usage-combineOccurences _ (Observed loc) (Observed _) = return $ Observed loc-combineOccurences name (Consumed wloc) (Observed rloc) =-  useAfterConsume name rloc wloc-combineOccurences name (Observed rloc) (Consumed wloc) =-  useAfterConsume name rloc wloc-combineOccurences name (Consumed loc1) (Consumed loc2) =-  useAfterConsume name (max loc1 loc2) (min loc1 loc2)--checkOccurences :: Occurences -> TermTypeM ()-checkOccurences = void . M.traverseWithKey comb . usageMap-  where-    comb _ [] = return ()-    comb name (u : us) = foldM_ (combineOccurences name) u us--allObserved :: Occurences -> Names-allObserved = S.unions . map observed--allConsumed :: Occurences -> Names-allConsumed = S.unions . map (fromMaybe mempty . consumed)--allOccuring :: Occurences -> Names-allOccuring occs = allConsumed occs <> allObserved occs--anyConsumption :: Occurences -> Maybe Occurence-anyConsumption = find (isJust . consumed)--seqOccurences :: Occurences -> Occurences -> Occurences-seqOccurences occurs1 occurs2 =-  filter (not . nullOccurence) $ map filt occurs1 ++ occurs2-  where-    filt occ =-      occ {observed = observed occ `S.difference` postcons}-    postcons = allConsumed occurs2--altOccurences :: Occurences -> Occurences -> Occurences-altOccurences occurs1 occurs2 =-  filter (not . nullOccurence) $ map filt1 occurs1 ++ map filt2 occurs2-  where-    filt1 occ =-      occ-        { consumed = S.difference <$> consumed occ <*> pure cons2,-          observed = observed occ `S.difference` cons2-        }-    filt2 occ =-      occ-        { consumed = consumed occ,-          observed = observed occ `S.difference` cons1-        }-    cons1 = allConsumed occurs1-    cons2 = allConsumed occurs2----- Scope management--data Checking-  = CheckingApply (Maybe (QualName VName)) Exp StructType StructType-  | CheckingReturn StructType StructType-  | CheckingAscription StructType StructType-  | CheckingLetGeneralise Name-  | CheckingParams (Maybe Name)-  | CheckingPat UncheckedPat InferredType-  | CheckingLoopBody StructType StructType-  | CheckingLoopInitial StructType StructType-  | CheckingRecordUpdate [Name] StructType StructType-  | CheckingRequired [StructType] StructType-  | CheckingBranches StructType StructType--instance Pretty Checking where-  ppr (CheckingApply f e expected actual) =-    header-      </> "Expected:" <+> align (ppr expected)-      </> "Actual:  " <+> align (ppr actual)-    where-      header =-        case f of-          Nothing ->-            "Cannot apply function to"-              <+> pquote (shorten $ pretty $ flatten $ ppr e) <> " (invalid type)."-          Just fname ->-            "Cannot apply" <+> pquote (ppr fname) <+> "to"-              <+> pquote (shorten $ pretty $ flatten $ ppr e) <> " (invalid type)."-  ppr (CheckingReturn expected actual) =-    "Function body does not have expected type."-      </> "Expected:" <+> align (ppr expected)-      </> "Actual:  " <+> align (ppr actual)-  ppr (CheckingAscription expected actual) =-    "Expression does not have expected type from explicit ascription."-      </> "Expected:" <+> align (ppr expected)-      </> "Actual:  " <+> align (ppr actual)-  ppr (CheckingLetGeneralise fname) =-    "Cannot generalise type of" <+> pquote (ppr fname) <> "."-  ppr (CheckingParams fname) =-    "Invalid use of parameters in" <+> pquote fname' <> "."-    where-      fname' = maybe "anonymous function" ppr fname-  ppr (CheckingPat pat NoneInferred) =-    "Invalid pattern" <+> pquote (ppr pat) <> "."-  ppr (CheckingPat pat (Ascribed t)) =-    "Pat" <+> pquote (ppr pat)-      <+> "cannot match value of type"-      </> indent 2 (ppr t)-  ppr (CheckingLoopBody expected actual) =-    "Loop body does not have expected type."-      </> "Expected:" <+> align (ppr expected)-      </> "Actual:  " <+> align (ppr actual)-  ppr (CheckingLoopInitial expected actual) =-    "Initial loop values do not have expected type."-      </> "Expected:" <+> align (ppr expected)-      </> "Actual:  " <+> align (ppr actual)-  ppr (CheckingRecordUpdate fs expected actual) =-    "Type mismatch when updating record field" <+> pquote fs' <> "."-      </> "Existing:" <+> align (ppr expected)-      </> "New:     " <+> align (ppr actual)-    where-      fs' = mconcat $ punctuate "." $ map ppr fs-  ppr (CheckingRequired [expected] actual) =-    "Expression must must have type" <+> ppr expected <> "."-      </> "Actual type:" <+> align (ppr actual)-  ppr (CheckingRequired expected actual) =-    "Type of expression must must be one of " <+> expected' <> "."-      </> "Actual type:" <+> align (ppr actual)-    where-      expected' = commasep (map ppr expected)-  ppr (CheckingBranches t1 t2) =-    "Conditional branches differ in type."-      </> "Former:" <+> ppr t1-      </> "Latter:" <+> ppr t2---- | Whether something is a global or a local variable.-data Locality = Local | Global-  deriving (Show)--data ValBinding-  = -- | Aliases in parameters indicate the lexical-    -- closure.-    BoundV Locality [TypeParam] PatType-  | OverloadedF [PrimType] [Maybe PrimType] (Maybe PrimType)-  | EqualityF-  | WasConsumed SrcLoc-  deriving (Show)---- | Type checking happens with access to this environment.  The--- 'TermScope' will be extended during type-checking as bindings come into--- scope.-data TermEnv = TermEnv-  { termScope :: TermScope,-    termChecking :: Maybe Checking,-    termLevel :: Level-  }--data TermScope = TermScope-  { scopeVtable :: M.Map VName ValBinding,-    scopeTypeTable :: M.Map VName TypeBinding,-    scopeModTable :: M.Map VName Mod,-    scopeNameMap :: NameMap-  }-  deriving (Show)--instance Semigroup TermScope where-  TermScope vt1 tt1 mt1 nt1 <> TermScope vt2 tt2 mt2 nt2 =-    TermScope (vt2 `M.union` vt1) (tt2 `M.union` tt1) (mt1 `M.union` mt2) (nt2 `M.union` nt1)--envToTermScope :: Env -> TermScope-envToTermScope env =-  TermScope-    { scopeVtable = vtable,-      scopeTypeTable = envTypeTable env,-      scopeNameMap = envNameMap env,-      scopeModTable = envModTable env-    }-  where-    vtable = M.mapWithKey valBinding $ envVtable env-    valBinding k (TypeM.BoundV tps v) =-      BoundV Global tps $-        v-          `setAliases` (if arrayRank v > 0 then S.singleton (AliasBound k) else mempty)--withEnv :: TermEnv -> Env -> TermEnv-withEnv tenv env = tenv {termScope = termScope tenv <> envToTermScope env}--overloadedTypeVars :: Constraints -> Names-overloadedTypeVars = mconcat . map f . M.elems-  where-    f (_, HasFields fs _) = mconcat $ map typeVars $ M.elems fs-    f _ = mempty---- | Get the type of an expression, with top level type variables--- substituted.  Never call 'typeOf' directly (except in a few--- carefully inspected locations)!-expType :: Exp -> TermTypeM PatType-expType = normPatType . typeOf---- | Get the type of an expression, with all type variables--- substituted.  Slower than 'expType', but sometimes necessary.--- Never call 'typeOf' directly (except in a few carefully inspected--- locations)!-expTypeFully :: Exp -> TermTypeM PatType-expTypeFully = normTypeFully . typeOf---- Wrap a function name to give it a vacuous Eq instance for SizeSource.-newtype FName = FName (Maybe (QualName VName))-  deriving (Show)--instance Eq FName where-  _ == _ = True--instance Ord FName where-  compare _ _ = EQ---- | What was the source of some existential size?  This is used for--- using the same existential variable if the same source is--- encountered in multiple locations.-data SizeSource-  = SourceArg FName (ExpBase NoInfo VName)-  | SourceBound (ExpBase NoInfo VName)-  | SourceSlice-      (Maybe (DimDecl VName))-      (Maybe (ExpBase NoInfo VName))-      (Maybe (ExpBase NoInfo VName))-      (Maybe (ExpBase NoInfo VName))-  deriving (Eq, Ord, Show)---- | A description of where an artificial compiler-generated--- intermediate name came from.-data NameReason-  = -- | Name is the result of a function application.-    NameAppRes (Maybe (QualName VName)) SrcLoc--nameReason :: SrcLoc -> NameReason -> Doc-nameReason loc (NameAppRes Nothing apploc) =-  "result of application at" <+> text (locStrRel loc apploc)-nameReason loc (NameAppRes fname apploc) =-  "result of applying" <+> pquote (ppr fname)-    <+> parens ("at" <+> text (locStrRel loc apploc))---- | The state is a set of constraints and a counter for generating--- type names.  This is distinct from the usual counter we use for--- generating unique names, as these will be user-visible.-data TermTypeState = TermTypeState-  { stateConstraints :: Constraints,-    stateCounter :: !Int,-    -- | Mapping function arguments encountered to-    -- the sizes they ended up generating (when-    -- they could not be substituted directly).-    -- This happens for function arguments that are-    -- not constants or names.-    stateDimTable :: M.Map SizeSource VName,-    stateNames :: M.Map VName NameReason,-    stateOccs :: Occurences-  }--newtype TermTypeM a-  = TermTypeM (ReaderT TermEnv (StateT TermTypeState TypeM) a)-  deriving-    ( Monad,-      Functor,-      Applicative,-      MonadReader TermEnv,-      MonadState TermTypeState,-      MonadError TypeError-    )--instance MonadUnify TermTypeM where-  getConstraints = gets stateConstraints-  putConstraints x = modify $ \s -> s {stateConstraints = x}--  newTypeVar loc desc = do-    i <- incCounter-    v <- newID $ mkTypeVarName desc i-    constrain v $ NoConstraint Lifted $ mkUsage' loc-    return $ Scalar $ TypeVar mempty Nonunique (typeName v) []--  curLevel = asks termLevel--  newDimVar loc rigidity name = do-    i <- incCounter-    dim <- newID $ mkTypeVarName name i-    case rigidity of-      Rigid rsrc -> constrain dim $ UnknowableSize loc rsrc-      Nonrigid -> constrain dim $ Size Nothing $ mkUsage' loc-    return dim--  unifyError loc notes bcs doc = do-    checking <- asks termChecking-    case checking of-      Just checking' ->-        throwError $-          TypeError (srclocOf loc) notes $-            ppr checking' <> line </> doc <> ppr bcs-      Nothing ->-        throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs--  matchError loc notes bcs t1 t2 = do-    checking <- asks termChecking-    case checking of-      Just checking'-        | hasNoBreadCrumbs bcs ->-          throwError $-            TypeError (srclocOf loc) notes $-              ppr checking'-        | otherwise ->-          throwError $-            TypeError (srclocOf loc) notes $-              ppr checking' <> line </> doc <> ppr bcs-      Nothing ->-        throwError $ TypeError (srclocOf loc) notes $ doc <> ppr bcs-    where-      doc =-        "Types"-          </> indent 2 (ppr t1)-          </> "and"-          </> indent 2 (ppr t2)-          </> "do not match."--onFailure :: Checking -> TermTypeM a -> TermTypeM a-onFailure c = local $ \env -> env {termChecking = Just c}--runTermTypeM :: TermTypeM a -> TypeM (a, Occurences)-runTermTypeM (TermTypeM m) = do-  initial_scope <- (initialTermScope <>) . envToTermScope <$> askEnv-  let initial_tenv =-        TermEnv-          { termScope = initial_scope,-            termChecking = Nothing,-            termLevel = 0-          }-  second stateOccs-    <$> runStateT-      (runReaderT m initial_tenv)-      (TermTypeState mempty 0 mempty mempty mempty)--liftTypeM :: TypeM a -> TermTypeM a-liftTypeM = TermTypeM . lift . lift--localScope :: (TermScope -> TermScope) -> TermTypeM a -> TermTypeM a-localScope f = local $ \tenv -> tenv {termScope = f $ termScope tenv}--incCounter :: TermTypeM Int-incCounter = do-  s <- get-  put s {stateCounter = stateCounter s + 1}-  return $ stateCounter s--extSize :: SrcLoc -> SizeSource -> TermTypeM (DimDecl VName, Maybe VName)-extSize loc e = do-  prev <- gets $ M.lookup e . stateDimTable-  case prev of-    Nothing -> do-      let rsrc = case e of-            SourceArg (FName fname) e' ->-              RigidArg fname $ prettyOneLine e'-            SourceBound e' ->-              RigidBound $ prettyOneLine e'-            SourceSlice d i j s ->-              RigidSlice d $ prettyOneLine $ DimSlice i j s-      d <- newDimVar loc (Rigid rsrc) "n"-      modify $ \s -> s {stateDimTable = M.insert e d $ stateDimTable s}-      return-        ( NamedDim $ qualName d,-          Just d-        )-    Just d ->-      return-        ( NamedDim $ qualName d,-          Just d-        )---- Any argument sizes created with 'extSize' inside the given action--- will be removed once the action finishes.  This is to ensure that--- just because e.g. @n+1@ appears as a size in one branch of a--- conditional, that doesn't mean it's also available in the other branch.-noSizeEscape :: TermTypeM a -> TermTypeM a-noSizeEscape m = do-  dimtable <- gets stateDimTable-  x <- m-  modify $ \s -> s {stateDimTable = dimtable}-  return x--constrain :: VName -> Constraint -> TermTypeM ()-constrain v c = do-  lvl <- curLevel-  modifyConstraints $ M.insert v (lvl, c)--incLevel :: TermTypeM a -> TermTypeM a-incLevel = local $ \env -> env {termLevel = termLevel env + 1}--initialTermScope :: TermScope-initialTermScope =-  TermScope-    { scopeVtable = initialVtable,-      scopeTypeTable = mempty,-      scopeNameMap = topLevelNameMap,-      scopeModTable = mempty-    }-  where-    initialVtable = M.fromList $ mapMaybe addIntrinsicF $ M.toList intrinsics--    prim = Scalar . Prim-    arrow x y = Scalar $ Arrow mempty Unnamed x y--    addIntrinsicF (name, IntrinsicMonoFun pts t) =-      Just (name, BoundV Global [] $ arrow pts' $ prim t)-      where-        pts' = case pts of-          [pt] -> prim pt-          _ -> tupleRecord $ map prim pts-    addIntrinsicF (name, IntrinsicOverloadedFun ts pts rts) =-      Just (name, OverloadedF ts pts rts)-    addIntrinsicF (name, IntrinsicPolyFun tvs pts rt) =-      Just-        ( name,-          BoundV Global tvs $-            fromStruct $ Scalar $ Arrow mempty Unnamed pts' rt-        )-      where-        pts' = case pts of-          [pt] -> pt-          _ -> tupleRecord pts-    addIntrinsicF (name, IntrinsicEquality) =-      Just (name, EqualityF)-    addIntrinsicF _ = Nothing--instance MonadTypeChecker TermTypeM where-  warn loc problem = liftTypeM $ warn loc problem-  newName = liftTypeM . newName-  newID = liftTypeM . newID--  checkQualName space name loc = snd <$> checkQualNameWithEnv space name loc--  bindNameMap m = localScope $ \scope ->-    scope {scopeNameMap = m <> scopeNameMap scope}--  bindVal v (TypeM.BoundV tps t) = localScope $ \scope ->-    scope {scopeVtable = M.insert v vb $ scopeVtable scope}-    where-      vb = BoundV Local tps $ fromStruct t--  lookupType loc qn = do-    outer_env <- liftTypeM askEnv-    (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc-    case M.lookup name $ scopeTypeTable scope of-      Nothing -> unknownType loc qn-      Just (TypeAbbr l ps def) ->-        return (qn', ps, qualifyTypeVars outer_env (map typeParamName ps) qs def, l)--  lookupMod loc qn = do-    (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Term qn loc-    case M.lookup name $ scopeModTable scope of-      Nothing -> unknownVariable Term qn loc-      Just m -> return (qn', m)--  lookupVar loc qn = do-    outer_env <- liftTypeM askEnv-    (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Term qn loc-    let usage = mkUsage loc $ "use of " ++ quote (pretty qn)--    t <- case M.lookup name $ scopeVtable scope of-      Nothing ->-        typeError loc mempty $-          "Unknown variable" <+> pquote (ppr qn) <> "."-      Just (WasConsumed wloc) -> useAfterConsume name loc wloc-      Just (BoundV _ tparams t)-        | "_" `isPrefixOf` baseString name -> underscoreUse loc qn-        | otherwise -> do-          (tnames, t') <- instantiateTypeScheme loc tparams t-          return $ qualifyTypeVars outer_env tnames qs t'-      Just EqualityF -> do-        argtype <- newTypeVar loc "t"-        equalityType usage argtype-        return $-          Scalar $-            Arrow mempty Unnamed argtype $-              Scalar $ Arrow mempty Unnamed argtype $ Scalar $ Prim Bool-      Just (OverloadedF ts pts rt) -> do-        argtype <- newTypeVar loc "t"-        mustBeOneOf ts usage argtype-        let (pts', rt') = instOverloaded argtype pts rt-            arrow xt yt = Scalar $ Arrow mempty Unnamed xt yt-        return $ fromStruct $ foldr arrow rt' pts'--    observe $ Ident name (Info t) loc-    return (qn', t)-    where-      instOverloaded argtype pts rt =-        ( map (maybe (toStruct argtype) (Scalar . Prim)) pts,-          maybe (toStruct argtype) (Scalar . Prim) rt-        )--  checkNamedDim loc v = do-    (v', t) <- lookupVar loc v-    onFailure (CheckingRequired [Scalar $ Prim $ Signed Int64] (toStruct t)) $-      unify (mkUsage loc "use as array size") (toStruct t) $-        Scalar $ Prim $ Signed Int64-    return v'--  typeError loc notes s = do-    checking <- asks termChecking-    case checking of-      Just checking' ->-        throwError $ TypeError (srclocOf loc) notes (ppr checking' <> line </> s)-      Nothing ->-        throwError $ TypeError (srclocOf loc) notes s--checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)-checkQualNameWithEnv space qn@(QualName quals name) loc = do-  scope <- asks termScope-  descend scope quals-  where-    descend scope []-      | Just name' <- M.lookup (space, name) $ scopeNameMap scope =-        return (scope, name')-      | otherwise =-        unknownVariable space qn loc-    descend scope (q : qs)-      | Just (QualName _ q') <- M.lookup (Term, q) $ scopeNameMap scope,-        Just res <- M.lookup q' $ scopeModTable scope =-        case res of-          -- Check if we are referring to the magical intrinsics-          -- module.-          _-            | baseTag q' <= maxIntrinsicTag ->-              checkIntrinsic space qn loc-          ModEnv q_scope -> do-            (scope', QualName qs' name') <- descend (envToTermScope q_scope) qs-            return (scope', QualName (q' : qs') name')-          ModFun {} -> unappliedFunctor loc-      | otherwise =-        unknownVariable space qn loc--checkIntrinsic :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)-checkIntrinsic space qn@(QualName _ name) loc-  | Just v <- M.lookup (space, name) intrinsicsNameMap = do-    me <- liftTypeM askImportName-    unless ("/prelude" `isPrefixOf` includeToFilePath me) $-      warn loc "Using intrinsic functions directly can easily crash the compiler or result in wrong code generation."-    scope <- asks termScope-    return (scope, v)-  | otherwise =-    unknownVariable space qn loc---- | Wrap 'Types.checkTypeDecl' to also perform an observation of--- every size in the type.-checkTypeDecl :: TypeDeclBase NoInfo Name -> TermTypeM (TypeDeclBase Info VName)-checkTypeDecl tdecl = do-  (tdecl', _) <- Types.checkTypeDecl tdecl-  mapM_ observeDim $ nestedDims $ unInfo $ expandedType tdecl'-  return tdecl'-  where-    observeDim (NamedDim v) =-      observe $ Ident (qualLeaf v) (Info $ Scalar $ Prim $ Signed Int64) mempty-    observeDim _ = return ()---- | Instantiate a type scheme with fresh type variables for its type--- parameters. Returns the names of the fresh type variables, the--- instance list, and the instantiated type.-instantiateTypeScheme ::-  SrcLoc ->-  [TypeParam] ->-  PatType ->-  TermTypeM ([VName], PatType)-instantiateTypeScheme loc tparams t = do-  let tnames = map typeParamName tparams-  (tparam_names, tparam_substs) <- unzip <$> mapM (instantiateTypeParam loc) tparams-  let substs = M.fromList $ zip tnames tparam_substs-      t' = applySubst (`M.lookup` substs) t-  return (tparam_names, t')---- | Create a new type name and insert it (unconstrained) in the--- substitution map.-instantiateTypeParam :: Monoid as => SrcLoc -> TypeParam -> TermTypeM (VName, Subst (TypeBase dim as))-instantiateTypeParam loc tparam = do-  i <- incCounter-  v <- newID $ mkTypeVarName (takeWhile isAscii (baseString (typeParamName tparam))) i-  case tparam of-    TypeParamType x _ _ -> do-      constrain v $ NoConstraint x $ mkUsage' loc-      return (v, Subst [] $ Scalar $ TypeVar mempty Nonunique (typeName v) [])-    TypeParamDim {} -> do-      constrain v $ Size Nothing $ mkUsage' loc-      return (v, SizeSubst $ NamedDim $ qualName v)--newArrayType :: SrcLoc -> String -> Int -> TermTypeM (StructType, StructType)-newArrayType loc desc r = do-  v <- newID $ nameFromString desc-  constrain v $ NoConstraint Unlifted $ mkUsage' loc-  dims <- replicateM r $ newDimVar loc Nonrigid "dim"-  let rowt = TypeVar () Nonunique (typeName v) []-  return-    ( Array () Nonunique rowt (ShapeDecl $ map (NamedDim . qualName) dims),-      Scalar rowt-    )----- Errors--useAfterConsume :: VName -> SrcLoc -> SrcLoc -> TermTypeM a-useAfterConsume name rloc wloc = do-  name' <- describeVar rloc name-  typeError rloc mempty . withIndexLink "use-after-consume" $-    "Using" <+> name' <> ", but this was consumed at"-      <+> text (locStrRel rloc wloc) <> ".  (Possibly through aliasing.)"--badLetWithValue :: (Pretty arr, Pretty src) => arr -> src -> SrcLoc -> TermTypeM a-badLetWithValue arre vale loc =-  typeError loc mempty $-    "Source array for in-place update"-      </> indent 2 (ppr arre)-      </> "might alias update value"-      </> indent 2 (ppr vale)-      </> "Hint: use" <+> pquote "copy" <+> "to remove aliases from the value."--returnAliased :: Name -> Name -> SrcLoc -> TermTypeM ()-returnAliased fname name loc =-  typeError loc mempty . withIndexLink "return-aliased" $-    "Unique-typed return value of" <+> pquote (pprName fname)-      <+> "is aliased to"-      <+> pquote (pprName name) <> ", which is not consumable."--uniqueReturnAliased :: Name -> SrcLoc -> TermTypeM a-uniqueReturnAliased fname loc =-  typeError loc mempty . withIndexLink "unique-return-aliased" $-    "A unique-typed component of the return value of"-      <+> pquote (pprName fname)-      <+> "is aliased to some other component."--unexpectedType :: MonadTypeChecker m => SrcLoc -> StructType -> [StructType] -> m a-unexpectedType loc _ [] =-  typeError loc mempty $-    "Type of expression at" <+> text (locStr loc)-      <+> "cannot have any type - possibly a bug in the type checker."-unexpectedType loc t ts =-  typeError loc mempty $-    "Type of expression at" <+> text (locStr loc) <+> "must be one of"-      <+> commasep (map ppr ts) <> ", but is"-      <+> ppr t <> "."--notConsumable :: MonadTypeChecker m => SrcLoc -> Doc -> m b-notConsumable loc v =-  typeError loc mempty . withIndexLink "not-consumable" $-    "Would consume" <+> v <> ", which is not consumable."--unusedSize :: (MonadTypeChecker m) => SizeBinder VName -> m a-unusedSize p =-  typeError p mempty . withIndexLink "unused-size" $-    "Size" <+> ppr p <+> "unused in pattern."----- Basic checking---- | Determine if the two types of identical, ignoring uniqueness.--- Mismatched dimensions are turned into fresh rigid type variables.--- Causes a 'TypeError' if they fail to match, and otherwise returns--- one of them.-unifyBranchTypes :: SrcLoc -> PatType -> PatType -> TermTypeM (PatType, [VName])-unifyBranchTypes loc t1 t2 =-  onFailure (CheckingBranches (toStruct t1) (toStruct t2)) $-    unifyMostCommon (mkUsage loc "unification of branch results") t1 t2--unifyBranches :: SrcLoc -> Exp -> Exp -> TermTypeM (PatType, [VName])-unifyBranches loc e1 e2 = do-  e1_t <- expTypeFully e1-  e2_t <- expTypeFully e2-  unifyBranchTypes loc e1_t e2_t----- General binding.--doNotShadow :: [String]-doNotShadow = ["&&", "||"]--data InferredType-  = NoneInferred-  | Ascribed PatType---- All this complexity is just so we can handle un-suffixed numeric--- literals in patterns.-patLitMkType :: PatLit -> SrcLoc -> TermTypeM StructType-patLitMkType (PatLitInt _) loc = do-  t <- newTypeVar loc "t"-  mustBeOneOf anyNumberType (mkUsage loc "integer literal") t-  return t-patLitMkType (PatLitFloat _) loc = do-  t <- newTypeVar loc "t"-  mustBeOneOf anyFloatType (mkUsage loc "float literal") t-  return t-patLitMkType (PatLitPrim v) _ =-  pure $ Scalar $ Prim $ primValueType v--nonrigidFor :: [SizeBinder VName] -> StructType -> TermTypeM StructType-nonrigidFor [] t = pure t -- Minor optimisation.-nonrigidFor sizes t = evalStateT (bitraverse onDim pure t) mempty-  where-    onDim (NamedDim (QualName _ v))-      | Just size <- find ((== v) . sizeName) sizes = do-        prev <- gets $ lookup v-        case prev of-          Nothing -> do-            v' <- lift $ newID $ baseName v-            lift $ constrain v' $ Size Nothing $ mkUsage' $ srclocOf size-            modify ((v, v') :)-            pure $ NamedDim $ qualName v'-          Just v' ->-            pure $ NamedDim $ qualName v'-    onDim d = pure d--checkPat' ::-  [SizeBinder VName] ->-  UncheckedPat ->-  InferredType ->-  TermTypeM Pat-checkPat' sizes (PatParens p loc) t =-  PatParens <$> checkPat' sizes p t <*> pure loc-checkPat' _ (Id name _ loc) _-  | name' `elem` doNotShadow =-    typeError loc mempty $ "The" <+> text name' <+> "operator may not be redefined."-  where-    name' = nameToString name-checkPat' _ (Id name NoInfo loc) (Ascribed t) = do-  name' <- newID name-  return $ Id name' (Info t) loc-checkPat' _ (Id name NoInfo loc) NoneInferred = do-  name' <- newID name-  t <- newTypeVar loc "t"-  return $ Id name' (Info t) loc-checkPat' _ (Wildcard _ loc) (Ascribed t) =-  return $ Wildcard (Info $ t `setUniqueness` Nonunique) loc-checkPat' _ (Wildcard NoInfo loc) NoneInferred = do-  t <- newTypeVar loc "t"-  return $ Wildcard (Info t) loc-checkPat' sizes (TuplePat ps loc) (Ascribed t)-  | Just ts <- isTupleRecord t,-    length ts == length ps =-    TuplePat-      <$> zipWithM (checkPat' sizes) ps (map Ascribed ts)-      <*> pure loc-checkPat' sizes p@(TuplePat ps loc) (Ascribed t) = do-  ps_t <- replicateM (length ps) (newTypeVar loc "t")-  unify (mkUsage loc "matching a tuple pattern") (tupleRecord ps_t) $ toStruct t-  t' <- normTypeFully t-  checkPat' sizes p $ Ascribed t'-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 $-      "Underscore-prefixed fields are not allowed."-        </> "Did you mean" <> dquotes (text (drop 1 (nameToString f)) <> "=_") <> "?"-checkPat' sizes (RecordPat p_fs loc) (Ascribed (Scalar (Record t_fs)))-  | sort (map fst p_fs) == sort (M.keys t_fs) =-    RecordPat . M.toList <$> check <*> pure loc-  where-    check =-      traverse (uncurry (checkPat' sizes)) $-        M.intersectionWith (,) (M.fromList p_fs) (fmap Ascribed t_fs)-checkPat' sizes p@(RecordPat fields loc) (Ascribed t) = do-  fields' <- traverse (const $ newTypeVar loc "t") $ M.fromList fields--  when (sort (M.keys fields') /= sort (map fst fields)) $-    typeError loc mempty $ "Duplicate fields in record pattern" <+> ppr p <> "."--  unify (mkUsage loc "matching a record pattern") (Scalar (Record fields')) $ toStruct t-  t' <- normTypeFully t-  checkPat' sizes p $ Ascribed t'-checkPat' sizes (RecordPat fs loc) NoneInferred =-  RecordPat . M.toList-    <$> traverse (\p -> checkPat' sizes p NoneInferred) (M.fromList fs)-    <*> pure loc-checkPat' sizes (PatAscription p (TypeDecl t NoInfo) loc) maybe_outer_t = do-  (t', st_nodims, _) <- checkTypeExp t-  (st, _) <- instantiateEmptyArrayDims loc "impl" Nonrigid st_nodims--  let st' = fromStruct st-  case maybe_outer_t of-    Ascribed outer_t -> do-      st_forunify <- nonrigidFor sizes st-      unify (mkUsage loc "explicit type ascription") st_forunify (toStruct outer_t)--      -- We also have to make sure that uniqueness matches.  This is-      -- done explicitly, because it is ignored by unification.-      st'' <- normTypeFully st'-      outer_t' <- normTypeFully outer_t-      case unifyTypesU unifyUniqueness st'' outer_t' of-        Just outer_t'' ->-          PatAscription <$> checkPat' sizes p (Ascribed outer_t'')-            <*> pure (TypeDecl t' (Info st))-            <*> pure loc-        Nothing ->-          typeError loc mempty $-            "Cannot match type" <+> pquote (ppr outer_t') <+> "with expected type"-              <+> pquote (ppr st'') <> "."-    NoneInferred ->-      PatAscription <$> checkPat' sizes p (Ascribed st')-        <*> pure (TypeDecl t' (Info st))-        <*> pure loc-  where-    unifyUniqueness u1 u2 = if u2 `subuniqueOf` u1 then Just u1 else Nothing-checkPat' _ (PatLit l NoInfo loc) (Ascribed t) = do-  t' <- patLitMkType l loc-  unify (mkUsage loc "matching against literal") t' (toStruct t)-  return $ PatLit l (Info (fromStruct t')) loc-checkPat' _ (PatLit l NoInfo loc) NoneInferred = do-  t' <- patLitMkType l loc-  return $ PatLit l (Info (fromStruct t')) loc-checkPat' sizes (PatConstr n NoInfo ps loc) (Ascribed (Scalar (Sum cs)))-  | Just ts <- M.lookup n cs = do-    ps' <- zipWithM (checkPat' sizes) ps $ map Ascribed ts-    return $ PatConstr n (Info (Scalar (Sum cs))) ps' loc-checkPat' sizes (PatConstr n NoInfo ps loc) (Ascribed t) = do-  t' <- newTypeVar loc "t"-  ps' <- mapM (\p -> checkPat' sizes p NoneInferred) ps-  mustHaveConstr usage n t' (patternStructType <$> ps')-  unify usage t' (toStruct t)-  t'' <- normTypeFully t-  return $ PatConstr n (Info t'') ps' loc-  where-    usage = mkUsage loc "matching against constructor"-checkPat' sizes (PatConstr n NoInfo ps loc) NoneInferred = do-  ps' <- mapM (\p -> checkPat' sizes p NoneInferred) ps-  t <- newTypeVar loc "t"-  mustHaveConstr usage n t (patternStructType <$> ps')-  return $ PatConstr n (Info $ fromStruct t) ps' loc-  where-    usage = mkUsage loc "matching against constructor"--patternNameMap :: Pat -> NameMap-patternNameMap = M.fromList . map asTerm . S.toList . patNames-  where-    asTerm v = ((Term, baseName v), qualName v)--checkPat ::-  [SizeBinder VName] ->-  UncheckedPat ->-  InferredType ->-  (Pat -> TermTypeM a) ->-  TermTypeM a-checkPat sizes p t m = do-  checkForDuplicateNames [p]-  p' <- onFailure (CheckingPat p t) $ checkPat' sizes p t--  let explicit = mustBeExplicitInType $ patternStructType p'--  case filter ((`S.member` explicit) . sizeName) sizes of-    size : _ ->-      typeError size mempty $-        "Cannot bind" <+> ppr size-          <+> "as it is never used as the size of a concrete (non-function) value."-    [] ->-      bindNameMap (patternNameMap p') $ m p'--binding :: [Ident] -> TermTypeM a -> TermTypeM a-binding stms = check . handleVars-  where-    handleVars m =-      localScope (`bindVars` stms) $ do-        -- Those identifiers that can potentially also be sizes are-        -- added as type constraints.  This is necessary so that we-        -- can properly detect scope violations during unification.-        -- We do this for *all* identifiers, not just those that are-        -- integers, because they may become integers later due to-        -- inference...-        forM_ stms $ \ident ->-          constrain (identName ident) $ ParamSize $ srclocOf ident-        m--    bindVars :: TermScope -> [Ident] -> TermScope-    bindVars = foldl bindVar--    bindVar :: TermScope -> Ident -> TermScope-    bindVar scope (Ident name (Info tp) _) =-      let inedges = boundAliases $ aliases tp-          update (BoundV l tparams in_t)-            -- If 'name' is record or sum-typed, don't alias the-            -- components to 'name', because these no identity-            -- beyond their components.-            | Array {} <- tp = BoundV l tparams (in_t `addAliases` S.insert (AliasBound name))-            | otherwise = BoundV l tparams in_t-          update b = b--          tp' = tp `addAliases` S.insert (AliasBound name)-       in scope-            { scopeVtable =-                M.insert name (BoundV Local [] tp') $-                  adjustSeveral update inedges $-                    scopeVtable scope-            }--    adjustSeveral f = flip $ foldl $ flip $ M.adjust f--    -- Check whether the bound variables have been used correctly-    -- within their scope.-    check m = do-      (a, usages) <- collectBindingsOccurences m-      checkOccurences usages--      mapM_ (checkIfUsed usages) stms--      return a--    -- Collect and remove all occurences in @stms@.  This relies-    -- on the fact that no variables shadow any other.-    collectBindingsOccurences m = do-      (x, usage) <- collectOccurences m-      let (relevant, rest) = split usage-      occur rest-      pure (x, relevant)-      where-        split =-          unzip-            . map-              ( \occ ->-                  let (obs1, obs2) = divide $ observed occ-                      occ_cons = divide <$> consumed occ-                      con1 = fst <$> occ_cons-                      con2 = snd <$> occ_cons-                   in ( occ {observed = obs1, consumed = con1},-                        occ {observed = obs2, consumed = con2}-                      )-              )-        names = S.fromList $ map identName stms-        divide s = (s `S.intersection` names, s `S.difference` names)--bindingTypes ::-  [Either (VName, TypeBinding) (VName, Constraint)] ->-  TermTypeM a ->-  TermTypeM a-bindingTypes types m = do-  lvl <- curLevel-  modifyConstraints (<> M.map (lvl,) (M.fromList constraints))-  localScope extend m-  where-    (tbinds, constraints) = partitionEithers types-    extend scope =-      scope-        { scopeTypeTable = M.fromList tbinds <> scopeTypeTable scope-        }--bindingTypeParams :: [TypeParam] -> TermTypeM a -> TermTypeM a-bindingTypeParams tparams =-  binding (mapMaybe typeParamIdent tparams)-    . bindingTypes (concatMap typeParamType tparams)-  where-    typeParamType (TypeParamType l v loc) =-      [ Left (v, TypeAbbr l [] (Scalar (TypeVar () Nonunique (typeName v) []))),-        Right (v, ParamType l loc)-      ]-    typeParamType (TypeParamDim v loc) =-      [Right (v, ParamSize loc)]--typeParamIdent :: TypeParam -> Maybe Ident-typeParamIdent (TypeParamDim v loc) =-  Just $ Ident v (Info $ Scalar $ Prim $ Signed Int64) loc-typeParamIdent _ = Nothing--bindingIdent ::-  IdentBase NoInfo Name ->-  PatType ->-  (Ident -> TermTypeM a) ->-  TermTypeM a-bindingIdent (Ident v NoInfo vloc) t m =-  bindSpaced [(Term, v)] $ do-    v' <- checkName Term v vloc-    let ident = Ident v' (Info t) vloc-    binding [ident] $ m ident--bindingParams ::-  [UncheckedTypeParam] ->-  [UncheckedPat] ->-  ([TypeParam] -> [Pat] -> TermTypeM a) ->-  TermTypeM a-bindingParams tps orig_ps m = do-  checkForDuplicateNames orig_ps-  checkTypeParams tps $ \tps' -> bindingTypeParams tps' $ do-    let descend ps' (p : ps) =-          checkPat [] p NoneInferred $ \p' ->-            binding (S.toList $ patIdents p') $ descend (p' : ps') ps-        descend ps' [] = do-          -- Perform an observation of every type parameter.  This-          -- prevents unused-name warnings for otherwise unused-          -- dimensions.-          mapM_ observe $ mapMaybe typeParamIdent tps'-          m tps' $ reverse ps'--    descend [] orig_ps--bindingSizes :: [SizeBinder Name] -> ([SizeBinder VName] -> TermTypeM a) -> TermTypeM a-bindingSizes [] m = m [] -- Minor optimisation.-bindingSizes sizes m = do-  foldM_ lookForDuplicates mempty sizes-  bindSpaced (map sizeWithSpace sizes) $ do-    sizes' <- mapM check sizes-    binding (map sizeWithType sizes') $ m sizes'-  where-    lookForDuplicates prev size-      | Just prevloc <- M.lookup (sizeName size) prev =-        typeError size mempty $-          "Size name also bound at "-            <> text (locStrRel (srclocOf size) prevloc)-            <> "."-      | otherwise =-        pure $ M.insert (sizeName size) (srclocOf size) prev--    sizeWithSpace size =-      (Term, sizeName size)-    sizeWithType size =-      Ident (sizeName size) (Info (Scalar (Prim (Signed Int64)))) (srclocOf size)--    check (SizeBinder v loc) =-      SizeBinder <$> checkName Term v loc <*> pure loc--bindingPat ::-  [SizeBinder VName] ->-  PatBase NoInfo Name ->-  InferredType ->-  (Pat -> TermTypeM a) ->-  TermTypeM a-bindingPat sizes p t m = do-  checkForDuplicateNames [p]-  checkPat sizes p t $ \p' -> binding (S.toList $ patIdents p') $ do-    -- Perform an observation of every declared dimension.  This-    -- prevents unused-name warnings for otherwise unused dimensions.-    mapM_ observe $ patternDims p'--    let used_sizes = typeDimNames $ patternStructType p'-    case filter ((`S.notMember` used_sizes) . sizeName) sizes of-      [] -> m p'-      size : _ -> unusedSize size--patternDims :: Pat -> [Ident]-patternDims (PatParens p _) = patternDims p-patternDims (TuplePat pats _) = concatMap patternDims pats-patternDims (PatAscription p (TypeDecl _ (Info t)) _) =-  patternDims p <> mapMaybe (dimIdent (srclocOf p)) (nestedDims t)-  where-    dimIdent _ (AnyDim _) = Nothing-    dimIdent _ (ConstDim _) = Nothing-    dimIdent _ NamedDim {} = Nothing-patternDims _ = []--sliceShape ::-  Maybe (SrcLoc, Rigidity) ->-  Slice ->-  TypeBase (DimDecl VName) as ->-  TermTypeM (TypeBase (DimDecl VName) as, [VName])-sliceShape r slice t@(Array als u et (ShapeDecl orig_dims)) =-  runStateT (setDims <$> adjustDims slice orig_dims) []-  where-    setDims [] = stripArray (length orig_dims) t-    setDims dims' = Array als u et $ ShapeDecl dims'--    -- If the result is supposed to be AnyDim or a nonrigid size-    -- variable, then don't bother trying to create-    -- non-existential sizes.  This is necessary to make programs-    -- type-check without too much ceremony; see-    -- e.g. tests/inplace5.fut.-    isRigid Rigid {} = True-    isRigid _ = False-    refine_sizes = maybe False (isRigid . snd) r--    sliceSize orig_d i j stride =-      case r of-        Just (loc, Rigid _) -> do-          (d, ext) <--            lift $-              extSize loc $-                SourceSlice orig_d' (bareExp <$> i) (bareExp <$> j) (bareExp <$> stride)-          modify (maybeToList ext ++)-          return d-        Just (loc, Nonrigid) ->-          lift $ NamedDim . qualName <$> newDimVar loc Nonrigid "slice_dim"-        Nothing ->-          pure $ AnyDim Nothing-      where-        -- The original size does not matter if the slice is fully specified.-        orig_d'-          | isJust i, isJust j = Nothing-          | otherwise = Just orig_d--    adjustDims (DimFix {} : idxes') (_ : dims) =-      adjustDims idxes' dims-    -- Pat match some known slices to be non-existential.-    adjustDims (DimSlice i j stride : idxes') (_ : dims)-      | refine_sizes,-        maybe True ((== Just 0) . isInt64) i,-        Just j' <- maybeDimFromExp =<< j,-        maybe True ((== Just 1) . isInt64) stride =-        (j' :) <$> adjustDims idxes' dims-    adjustDims (DimSlice Nothing Nothing stride : idxes') (d : dims)-      | refine_sizes,-        maybe True (maybe False ((== 1) . abs) . isInt64) stride =-        (d :) <$> adjustDims idxes' dims-    adjustDims (DimSlice i j stride : idxes') (d : dims) =-      (:) <$> sliceSize d i j stride <*> adjustDims idxes' dims-    adjustDims _ dims =-      pure dims-sliceShape _ _ t = pure (t, [])----- Main checkers---- | @require ts e@ causes a 'TypeError' if @expType e@ is not one of--- the types in @ts@.  Otherwise, simply returns @e@.-require :: String -> [PrimType] -> Exp -> TermTypeM Exp-require why ts e = do-  mustBeOneOf ts (mkUsage (srclocOf e) why) . toStruct =<< expType e-  return e--unifies :: String -> StructType -> Exp -> TermTypeM Exp-unifies why t e = do-  unify (mkUsage (srclocOf e) why) t . toStruct =<< expType e-  return e---- The closure of a lambda or local function are those variables that--- it references, and which local to the current top-level function.-lexicalClosure :: [Pat] -> Occurences -> TermTypeM Aliasing-lexicalClosure params closure = do-  vtable <- asks $ scopeVtable . termScope-  let isLocal v = case v `M.lookup` vtable of-        Just (BoundV Local _ _) -> True-        _ -> False-  return $-    S.map AliasBound $-      S.filter isLocal $-        allOccuring closure S.\\ mconcat (map patNames params)--noAliasesIfOverloaded :: PatType -> TermTypeM PatType-noAliasesIfOverloaded t@(Scalar (TypeVar _ u tn [])) = do-  subst <- fmap snd . M.lookup (typeLeaf tn) <$> getConstraints-  case subst of-    Just Overloaded {} -> return $ Scalar $ TypeVar mempty u tn []-    _ -> return t-noAliasesIfOverloaded t =-  return t---- Check the common parts of ascription and coercion.-checkAscript ::-  SrcLoc ->-  UncheckedTypeDecl ->-  UncheckedExp ->-  (StructType -> TermTypeM StructType) ->-  TermTypeM (TypeDecl, Exp)-checkAscript loc decl e shapef = do-  decl' <- checkTypeDecl decl-  e' <- checkExp e-  t <- expTypeFully e'--  (decl_t_nonrigid, _) <--    instantiateEmptyArrayDims loc "impl" Nonrigid-      =<< shapef (unInfo $ expandedType decl')--  onFailure (CheckingAscription (unInfo $ expandedType decl') (toStruct t)) $-    unify (mkUsage loc "type ascription") decl_t_nonrigid (toStruct t)--  -- We also have to make sure that uniqueness matches.  This is done-  -- explicitly, because uniqueness is ignored by unification.-  t' <- normTypeFully t-  decl_t' <- normTypeFully $ unInfo $ expandedType decl'-  unless (toStructural t' `subtypeOf` toStructural decl_t') $-    typeError loc mempty $-      "Type" <+> pquote (ppr t') <+> "is not a subtype of"-        <+> pquote (ppr decl_t') <> "."--  return (decl', e')--unscopeType ::-  SrcLoc ->-  M.Map VName Ident ->-  PatType ->-  TermTypeM (PatType, [VName])-unscopeType tloc unscoped t = do-  (t', m) <- runStateT (traverseDims onDim t) mempty-  return (t' `addAliases` S.map unAlias, M.elems m)-  where-    onDim _ p (NamedDim d)-      | Just loc <- srclocOf <$> M.lookup (qualLeaf d) unscoped =-        if p == PosImmediate || p == PosParam-          then inst loc $ qualLeaf d-          else return $ AnyDim $ Just $ qualLeaf d-    onDim _ _ d = return d--    inst loc d = do-      prev <- gets $ M.lookup d-      case prev of-        Just d' -> return $ NamedDim $ qualName d'-        Nothing -> do-          d' <- lift $ newDimVar tloc (Rigid $ RigidOutOfScope loc d) "d"-          modify $ M.insert d d'-          return $ NamedDim $ qualName d'--    unAlias (AliasBound v) | v `M.member` unscoped = AliasFree v-    unAlias a = a---- When a function result is not immediately bound to a name, we need--- to invent a name for it so we can track it during aliasing--- (uniqueness-error54.fut, uniqueness-error55.fut).-addResultAliases :: NameReason -> PatType -> TermTypeM PatType-addResultAliases r (Scalar (Record fs)) =-  Scalar . Record <$> traverse (addResultAliases r) fs-addResultAliases r (Scalar (Sum fs)) =-  Scalar . Sum <$> traverse (traverse (addResultAliases r)) fs-addResultAliases r (Scalar (TypeVar as u tn targs)) = do-  v <- newID "internal_app_result"-  modify $ \s -> s {stateNames = M.insert v r $ stateNames s}-  pure $ Scalar $ TypeVar (S.insert (AliasFree v) as) u tn targs-addResultAliases _ (Scalar t@Prim {}) = pure (Scalar t)-addResultAliases _ (Scalar t@Arrow {}) = pure (Scalar t)-addResultAliases r (Array als u t shape) = do-  v <- newID "internal_app_result"-  modify $ \s -> s {stateNames = M.insert v r $ stateNames s}-  pure $ Array (S.insert (AliasFree v) als) u t shape---- 'checkApplyExp' is like 'checkExp', but tries to find the "root--- function", for better error messages.-checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp)-checkApplyExp (AppExp (Apply e1 e2 _ loc) _) = do-  arg <- checkArg e2-  (e1', (fname, i)) <- checkApplyExp e1-  t <- expType e1'-  (t1, rt, argext, exts) <- checkApply loc (fname, i) t arg-  rt' <- addResultAliases (NameAppRes fname loc) rt-  return-    ( AppExp-        (Apply e1' (argExp arg) (Info (diet t1, argext)) loc)-        (Info $ AppRes rt' exts),-      (fname, i + 1)-    )-checkApplyExp e = do-  e' <- checkExp e-  return-    ( e',-      ( case e' of-          Var qn _ _ -> Just qn-          _ -> Nothing,-        0-      )-    )--checkExp :: UncheckedExp -> TermTypeM Exp-checkExp (Literal val loc) =-  return $ Literal val loc-checkExp (StringLit vs loc) =-  return $ StringLit vs loc-checkExp (IntLit val NoInfo loc) = do-  t <- newTypeVar loc "t"-  mustBeOneOf anyNumberType (mkUsage loc "integer literal") t-  return $ IntLit val (Info $ fromStruct t) loc-checkExp (FloatLit val NoInfo loc) = do-  t <- newTypeVar loc "t"-  mustBeOneOf anyFloatType (mkUsage loc "float literal") t-  return $ FloatLit val (Info $ fromStruct t) loc-checkExp (TupLit es loc) =-  TupLit <$> mapM checkExp es <*> pure loc-checkExp (RecordLit fs loc) = do-  fs' <- evalStateT (mapM checkField fs) mempty--  return $ RecordLit fs' loc-  where-    checkField (RecordFieldExplicit f e rloc) = do-      errIfAlreadySet f rloc-      modify $ M.insert f rloc-      RecordFieldExplicit f <$> lift (checkExp e) <*> pure rloc-    checkField (RecordFieldImplicit name NoInfo rloc) = do-      errIfAlreadySet name rloc-      (QualName _ name', t) <- lift $ lookupVar rloc $ qualName name-      modify $ M.insert name rloc-      return $ RecordFieldImplicit name' (Info t) rloc--    errIfAlreadySet f rloc = do-      maybe_sloc <- gets $ M.lookup f-      case maybe_sloc of-        Just sloc ->-          lift . typeError rloc mempty $-            "Field" <+> pquote (ppr f)-              <+> "previously defined at"-              <+> text (locStrRel rloc sloc) <> "."-        Nothing -> return ()-checkExp (ArrayLit all_es _ loc) =-  -- Construct the result type and unify all elements with it.  We-  -- only create a type variable for empty arrays; otherwise we use-  -- the type of the first element.  This significantly cuts down on-  -- the number of type variables generated for pathologically large-  -- multidimensional array literals.-  case all_es of-    [] -> do-      et <- newTypeVar loc "t"-      t <- arrayOfM loc et (ShapeDecl [ConstDim 0]) Unique-      return $ ArrayLit [] (Info t) loc-    e : es -> do-      e' <- checkExp e-      et <- expType e'-      es' <- mapM (unifies "type of first array element" (toStruct et) <=< checkExp) es-      et' <- normTypeFully et-      t <- arrayOfM loc et' (ShapeDecl [ConstDim $ length all_es]) Unique-      return $ ArrayLit (e' : es') (Info t) loc-checkExp (AppExp (Range start maybe_step end loc) _) = do-  start' <- require "use in range expression" anySignedType =<< checkExp start-  start_t <- toStruct <$> expTypeFully start'-  maybe_step' <- case maybe_step of-    Nothing -> return Nothing-    Just step -> do-      let warning = warn loc "First and second element of range are identical, this will produce an empty array."-      case (start, step) of-        (Literal x _, Literal y _) -> when (x == y) warning-        (Var x_name _ _, Var y_name _ _) -> when (x_name == y_name) warning-        _ -> return ()-      Just <$> (unifies "use in range expression" start_t =<< checkExp step)--  let unifyRange e = unifies "use in range expression" start_t =<< checkExp e-  end' <- traverse unifyRange end--  end_t <- case end' of-    DownToExclusive e -> expType e-    ToInclusive e -> expType e-    UpToExclusive e -> expType e--  -- Special case some ranges to give them a known size.-  let dimFromBound = dimFromExp (SourceBound . bareExp)-  (dim, retext) <--    case (isInt64 start', isInt64 <$> maybe_step', end') of-      (Just 0, Just (Just 1), UpToExclusive end'')-        | Scalar (Prim (Signed Int64)) <- end_t ->-          dimFromBound end''-      (Just 0, Nothing, UpToExclusive end'')-        | Scalar (Prim (Signed Int64)) <- end_t ->-          dimFromBound end''-      (Just 1, Just (Just 2), ToInclusive end'')-        | Scalar (Prim (Signed Int64)) <- end_t ->-          dimFromBound end''-      _ -> do-        d <- newDimVar loc (Rigid RigidRange) "range_dim"-        return (NamedDim $ qualName d, Just d)--  t <- arrayOfM loc start_t (ShapeDecl [dim]) Unique-  let res = AppRes (t `setAliases` mempty) (maybeToList retext)--  return $ AppExp (Range start' maybe_step' end' loc) (Info res)-checkExp (Ascript e decl loc) = do-  (decl', e') <- checkAscript loc decl e pure-  return $ Ascript e' decl' loc-checkExp (AppExp (Coerce e decl loc) _) = do-  -- We instantiate the declared types with all dimensions as nonrigid-  -- fresh type variables, which we then use to unify with the type of-  -- 'e'.  This lets 'e' have whatever sizes it wants, but the overall-  -- type must still match.  Eventually we will throw away those sizes-  -- (they will end up being unified with various sizes in 'e', which-  -- is fine).-  (decl', e') <- checkAscript loc decl e $ pure . anySizes--  -- Now we instantiate the declared type again, but this time we keep-  -- around the sizes as existentials.  This is the result of the-  -- ascription as a whole.  We use matchDims to obtain the aliasing-  -- of 'e'.-  (decl_t_rigid, ext) <--    instantiateDimsInReturnType loc Nothing $ unInfo $ expandedType decl'--  t <- expTypeFully e'--  t' <- matchDims (const pure) t $ fromStruct decl_t_rigid--  return $ AppExp (Coerce e' decl' loc) (Info $ AppRes t' ext)-checkExp (AppExp (BinOp (op, oploc) NoInfo (e1, _) (e2, _) loc) NoInfo) = do-  (op', ftype) <- lookupVar oploc op-  e1_arg <- checkArg e1-  e2_arg <- checkArg e2--  -- Note that the application to the first operand cannot fix any-  -- existential sizes, because it must by necessity be a function.-  (p1_t, rt, p1_ext, _) <- checkApply loc (Just op', 0) ftype e1_arg-  (p2_t, rt', p2_ext, retext) <- checkApply loc (Just op', 1) rt e2_arg--  return $-    AppExp-      ( BinOp-          (op', oploc)-          (Info ftype)-          (argExp e1_arg, Info (toStruct p1_t, p1_ext))-          (argExp e2_arg, Info (toStruct p2_t, p2_ext))-          loc-      )-      (Info (AppRes rt' retext))-checkExp (Project k e NoInfo loc) = do-  e' <- checkExp e-  t <- expType e'-  kt <- mustHaveField (mkUsage loc $ "projection of field " ++ quote (pretty k)) k t-  return $ Project k e' (Info kt) loc-checkExp (AppExp (If e1 e2 e3 loc) _) =-  sequentially checkCond $ \e1' _ -> do-    ((e2', e3'), dflow) <- tapOccurences $ checkExp e2 `alternative` checkExp e3--    (brancht, retext) <- unifyBranches loc e2' e3'-    let t' = addAliases brancht $ S.filter $ (`S.notMember` allConsumed dflow) . aliasVar--    zeroOrderType-      (mkUsage loc "returning value of this type from 'if' expression")-      "type returned from branch"-      t'--    return $ AppExp (If e1' e2' e3' loc) (Info $ AppRes t' retext)-  where-    checkCond = do-      e1' <- checkExp e1-      let bool = Scalar $ Prim Bool-      e1_t <- toStruct <$> expType e1'-      onFailure (CheckingRequired [bool] e1_t) $-        unify (mkUsage (srclocOf e1') "use as 'if' condition") bool e1_t-      return e1'-checkExp (Parens e loc) =-  Parens <$> checkExp e <*> pure loc-checkExp (QualParens (modname, modnameloc) e loc) = do-  (modname', mod) <- lookupMod loc modname-  case mod of-    ModEnv env -> local (`withEnv` qualifyEnv modname' env) $ do-      e' <- checkExp e-      return $ QualParens (modname', modnameloc) e' loc-    ModFun {} ->-      typeError loc mempty $ "Module" <+> ppr modname <+> " is a parametric module."-  where-    qualifyEnv modname' env =-      env {envNameMap = M.map (qualify' modname') $ envNameMap env}-    qualify' modname' (QualName qs name) =-      QualName (qualQuals modname' ++ [qualLeaf modname'] ++ qs) name-checkExp (Var qn NoInfo loc) = do-  -- The qualifiers of a variable is divided into two parts: first a-  -- possibly-empty sequence of module qualifiers, followed by a-  -- possible-empty sequence of record field accesses.  We use scope-  -- information to perform the split, by taking qualifiers off the-  -- end until we find a module.--  (qn', t, fields) <- findRootVar (qualQuals qn) (qualLeaf qn)--  foldM checkField (Var qn' (Info t) loc) fields-  where-    findRootVar qs name =-      (whenFound <$> lookupVar loc (QualName qs name)) `catchError` notFound qs name--    whenFound (qn', t) = (qn', t, [])--    notFound qs name err-      | null qs = throwError err-      | otherwise = do-        (qn', t, fields) <--          findRootVar (init qs) (last qs)-            `catchError` const (throwError err)-        return (qn', t, fields ++ [name])--    checkField e k = do-      t <- expType e-      let usage = mkUsage loc $ "projection of field " ++ quote (pretty k)-      kt <- mustHaveField usage k t-      return $ Project k e (Info kt) loc-checkExp (Negate arg loc) = do-  arg' <- require "numeric negation" anyNumberType =<< checkExp arg-  return $ Negate arg' loc-checkExp (Not arg loc) = do-  arg' <- require "logical negation" (Bool : anyIntType) =<< checkExp arg-  return $ Not arg' loc-checkExp e@(AppExp Apply {} _) = fst <$> checkApplyExp e-checkExp (AppExp (LetPat sizes pat e body loc) _) =-  sequentially (checkExp e) $ \e' e_occs -> do-    -- Not technically an ascription, but we want the pattern to have-    -- exactly the type of 'e'.-    t <- expType e'-    case anyConsumption e_occs of-      Just c ->-        let msg = "type computed with consumption at " ++ locStr (location c)-         in zeroOrderType (mkUsage loc "consumption in right-hand side of 'let'-binding") msg t-      _ -> return ()--    incLevel . bindingSizes sizes $ \sizes' ->-      bindingPat sizes' pat (Ascribed t) $ \pat' -> do-        body' <- checkExp body-        (body_t, retext) <--          unscopeType loc (sizesMap sizes' <> patternMap pat') =<< expTypeFully body'--        return $ AppExp (LetPat sizes' pat' e' body' loc) (Info $ AppRes body_t retext)-  where-    sizesMap = foldMap onSize-    onSize size =-      M.singleton (sizeName size) $-        Ident (sizeName size) (Info (Scalar $ Prim $ Signed Int64)) (srclocOf size)-checkExp (AppExp (LetFun name (tparams, params, maybe_retdecl, NoInfo, e) body loc) _) =-  sequentially (checkBinding (name, maybe_retdecl, tparams, params, e, loc)) $-    \(tparams', params', maybe_retdecl', rettype, _, e') closure -> do-      closure' <- lexicalClosure params' closure--      bindSpaced [(Term, name)] $ do-        name' <- checkName Term name loc--        let arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt-            ftype = foldr (arrow . patternParam) rettype params'-            entry = BoundV Local tparams' $ ftype `setAliases` closure'-            bindF scope =-              scope-                { scopeVtable =-                    M.insert name' entry $ scopeVtable scope,-                  scopeNameMap =-                    M.insert (Term, name) (qualName name') $-                      scopeNameMap scope-                }-        body' <- localScope bindF $ checkExp body--        -- We fake an ident here, but it's OK as it can't be a size-        -- anyway.-        let fake_ident = Ident name' (Info $ fromStruct ftype) mempty-        (body_t, ext) <--          unscopeType loc (M.singleton name' fake_ident)-            =<< expTypeFully body'--        return $-          AppExp-            ( LetFun-                name'-                (tparams', params', maybe_retdecl', Info rettype, e')-                body'-                loc-            )-            (Info $ AppRes body_t ext)-checkExp (AppExp (LetWith dest src slice ve body loc) _) =-  sequentially (checkIdent src) $ \src' _ -> do-    slice' <- checkSlice slice-    (t, _) <- newArrayType (srclocOf src) "src" $ sliceDims slice'-    unify (mkUsage loc "type of target array") t $ toStruct $ unInfo $ identType src'--    -- Need the fully normalised type here to get the proper aliasing information.-    src_t <- normTypeFully $ unInfo $ identType src'--    (elemt, _) <- sliceShape (Just (loc, Nonrigid)) slice' =<< normTypeFully t--    unless (unique src_t) $ notConsumable loc $ pquote $ pprName $ identName src--    sequentially (unifies "type of target array" (toStruct elemt) =<< checkExp ve) $ \ve' _ -> do-      ve_t <- expTypeFully ve'-      when (AliasBound (identName src') `S.member` aliases ve_t) $-        badLetWithValue src ve loc--      bindingIdent dest (src_t `setAliases` S.empty) $ \dest' -> do-        body' <- consuming src' $ checkExp body-        (body_t, ext) <--          unscopeType loc (M.singleton (identName dest') dest')-            =<< expTypeFully body'-        return $ AppExp (LetWith dest' src' slice' ve' body' loc) (Info $ AppRes body_t ext)-checkExp (Update src slice ve loc) = do-  slice' <- checkSlice slice-  (t, _) <- newArrayType (srclocOf src) "src" $ sliceDims slice'-  (elemt, _) <- sliceShape (Just (loc, Nonrigid)) slice' =<< normTypeFully t--  sequentially (checkExp ve >>= unifies "type of target array" elemt) $ \ve' _ ->-    sequentially (checkExp src >>= unifies "type of target array" t) $ \src' _ -> do-      src_t <- expTypeFully src'--      unless (unique src_t) $ notConsumable loc $ pquote $ ppr src--      let src_als = aliases src_t-      ve_t <- expTypeFully ve'-      unless (S.null $ src_als `S.intersection` aliases ve_t) $ badLetWithValue src ve loc--      consume loc src_als-      return $ Update src' slice' ve' loc---- Record updates are a bit hacky, because we do not have row typing--- (yet?).  For now, we only permit record updates where we know the--- full type up to the field we are updating.-checkExp (RecordUpdate src fields ve NoInfo loc) = do-  src' <- checkExp src-  ve' <- checkExp ve-  a <- expTypeFully src'-  foldM_ (flip $ mustHaveField usage) a fields-  ve_t <- expType ve'-  updated_t <- updateField fields ve_t =<< expTypeFully src'-  return $ RecordUpdate src' fields ve' (Info updated_t) loc-  where-    usage = mkUsage loc "record update"-    updateField [] ve_t src_t = do-      (src_t', _) <- instantiateEmptyArrayDims loc "any" Nonrigid $ anySizes src_t-      onFailure (CheckingRecordUpdate fields (toStruct src_t') (toStruct ve_t)) $-        unify usage (toStruct src_t') (toStruct ve_t)-      -- Important that we return ve_t so that we get the right aliases.-      pure ve_t-    updateField (f : fs) ve_t (Scalar (Record m))-      | Just f_t <- M.lookup f m = do-        f_t' <- updateField fs ve_t f_t-        pure $ Scalar $ Record $ M.insert f f_t' m-    updateField _ _ _ =-      typeError loc mempty $-        "Full type of"-          </> indent 2 (ppr src)-          </> textwrap " is not known at this point.  Add a size annotation to the original record to disambiguate."-----checkExp (AppExp (Index e slice loc) _) = do-  slice' <- checkSlice slice-  (t, _) <- newArrayType loc "e" $ sliceDims slice'-  e' <- unifies "being indexed at" t =<< checkExp e-  -- XXX, the RigidSlice here will be overridden in sliceShape with a proper value.-  (t', retext) <--    sliceShape (Just (loc, Rigid (RigidSlice Nothing ""))) slice'-      =<< expTypeFully e'--  -- Remove aliases if the result is an overloaded type, because that-  -- will certainly not be aliased.-  t'' <- noAliasesIfOverloaded t'--  return $ AppExp (Index e' slice' loc) (Info $ AppRes t'' retext)-checkExp (Assert e1 e2 NoInfo loc) = do-  e1' <- require "being asserted" [Bool] =<< checkExp e1-  e2' <- checkExp e2-  return $ Assert e1' e2' (Info (pretty e1)) loc-checkExp (Lambda params body rettype_te NoInfo loc) =-  removeSeminullOccurences . noUnique . incLevel . bindingParams [] params $ \_ params' -> do-    rettype_checked <- traverse checkTypeExp rettype_te-    let declared_rettype =-          case rettype_checked of-            Just (_, st, _) -> Just st-            Nothing -> Nothing-    (body', closure) <--      tapOccurences $ checkFunBody params' body declared_rettype loc-    body_t <- expTypeFully body'--    params'' <- mapM updateTypes params'--    (rettype', rettype_st) <--      case rettype_checked of-        Just (te, st, _) ->-          return (Just te, st)-        Nothing -> do-          ret <--            inferReturnSizes params'' $-              toStruct $-                inferReturnUniqueness params'' body_t-          return (Nothing, ret)--    checkGlobalAliases params' body_t loc-    verifyFunctionParams Nothing params'--    closure' <- lexicalClosure params'' closure--    return $ Lambda params'' body' rettype' (Info (closure', rettype_st)) loc-  where-    -- Inferring the sizes of the return type of a lambda is a lot-    -- like let-generalisation.  We wish to remove any rigid sizes-    -- that were created when checking the body, except for those that-    -- are visible in types that existed before we entered the body,-    -- are parameters, or are used in parameters.-    inferReturnSizes params' ret = do-      cur_lvl <- curLevel-      let named (Named x, _) = Just x-          named (Unnamed, _) = Nothing-          param_names = mapMaybe (named . patternParam) params'-          pos_sizes =-            typeDimNamesPos (foldFunType (map patternStructType params') ret)-          hide k (lvl, _) =-            lvl >= cur_lvl && k `notElem` param_names && k `S.notMember` pos_sizes--      hidden_sizes <--        S.fromList . M.keys . M.filterWithKey hide <$> getConstraints--      let onDim (NamedDim name)-            | not (qualLeaf name `S.member` hidden_sizes) = NamedDim name-            | otherwise = AnyDim $ Just $ qualLeaf name-          onDim d = d--      return $ first onDim ret-checkExp (OpSection op _ loc) = do-  (op', ftype) <- lookupVar loc op-  return $ OpSection op' (Info ftype) loc-checkExp (OpSectionLeft op _ e _ _ loc) = do-  (op', ftype) <- lookupVar loc op-  e_arg <- checkArg e-  (t1, rt, argext, retext) <- checkApply loc (Just op', 0) ftype e_arg-  case (ftype, rt) of-    (Scalar (Arrow _ m1 _ _), Scalar (Arrow _ m2 t2 rettype)) ->-      return $-        OpSectionLeft-          op'-          (Info ftype)-          (argExp e_arg)-          (Info (m1, toStruct t1, argext), Info (m2, toStruct t2))-          (Info rettype, Info retext)-          loc-    _ ->-      typeError loc mempty $-        "Operator section with invalid operator of type" <+> ppr ftype-checkExp (OpSectionRight op _ e _ NoInfo loc) = do-  (op', ftype) <- lookupVar loc op-  e_arg <- checkArg e-  case ftype of-    Scalar (Arrow as1 m1 t1 (Scalar (Arrow as2 m2 t2 ret))) -> do-      (t2', ret', argext, _) <--        checkApply-          loc-          (Just op', 1)-          (Scalar $ Arrow as2 m2 t2 $ Scalar $ Arrow as1 m1 t1 ret)-          e_arg-      return $-        OpSectionRight-          op'-          (Info ftype)-          (argExp e_arg)-          (Info (m1, toStruct t1), Info (m2, toStruct t2', argext))-          (Info $ addAliases ret (<> aliases ret'))-          loc-    _ ->-      typeError loc mempty $-        "Operator section with invalid operator of type" <+> ppr ftype-checkExp (ProjectSection fields NoInfo loc) = do-  a <- newTypeVar loc "a"-  let usage = mkUsage loc "projection at"-  b <- foldM (flip $ mustHaveField usage) a fields-  return $ ProjectSection fields (Info $ Scalar $ Arrow mempty Unnamed a b) loc-checkExp (IndexSection slice NoInfo loc) = do-  slice' <- checkSlice slice-  (t, _) <- newArrayType loc "e" $ sliceDims slice'-  (t', _) <- sliceShape Nothing slice' t-  return $ IndexSection slice' (Info $ fromStruct $ Scalar $ Arrow mempty Unnamed t t') loc-checkExp (AppExp (DoLoop _ mergepat mergeexp form loopbody loc) _) =-  sequentially (checkExp mergeexp) $ \mergeexp' _ -> do-    zeroOrderType-      (mkUsage (srclocOf mergeexp) "use as loop variable")-      "type used as loop variable"-      =<< expTypeFully mergeexp'--    -- The handling of dimension sizes is a bit intricate, but very-    -- similar to checking a function, followed by checking a call to-    -- it.  The overall procedure is as follows:-    ---    -- (1) All empty dimensions in the merge pattern are instantiated-    -- with nonrigid size variables.  All explicitly specified-    -- dimensions are preserved.-    ---    -- (2) The body of the loop is type-checked.  The result type is-    -- combined with the merge pattern type to determine which sizes are-    -- variant, and these are turned into size parameters for the merge-    -- pattern.-    ---    -- (3) We now conceptually have a function parameter type and return-    -- type.  We check that it can be called with the initial merge-    -- values as argument.  The result of this is the type of the loop-    -- as a whole.-    ---    -- (There is also a convergence loop for inferring uniqueness, but-    -- that's orthogonal to the size handling.)--    (merge_t, new_dims) <--      instantiateEmptyArrayDims loc "loop" Nonrigid-        . anySizes -- dim handling (1)-        =<< expTypeFully mergeexp'--    -- dim handling (2)-    let checkLoopReturnSize mergepat' loopbody' = do-          loopbody_t <- expTypeFully loopbody'-          pat_t <- normTypeFully $ patternType mergepat'-          -- We are ignoring the dimensions here, because any mismatches-          -- should be turned into fresh size variables.--          onFailure (CheckingLoopBody (toStruct (anySizes pat_t)) (toStruct loopbody_t)) $-            expect-              (mkUsage (srclocOf loopbody) "matching loop body to loop pattern")-              (toStruct (anyTheseSizes new_dims pat_t))-              (toStruct loopbody_t)-          pat_t' <- normTypeFully pat_t-          loopbody_t' <- normTypeFully loopbody_t--          -- For each new_dims, figure out what they are instantiated-          -- with in the initial value.  This is used to determine-          -- whether a size is invariant because it always matches the-          -- initial instantiation of that size.-          let initSubst (NamedDim v, d) = Just (v, d)-              initSubst _ = Nothing-          init_substs <--            M.fromList . mapMaybe initSubst . snd-              . anyDimOnMismatch pat_t'-              <$> expTypeFully mergeexp'--          -- Figure out which of the 'new_dims' dimensions are variant.-          -- This works because we know that each dimension from-          -- new_dims in the pattern is unique and distinct.-          ---          -- Our logic here is a bit reversed: the *mismatches* (from-          -- new_dims) are what we want to extract and turn into size-          -- parameters.-          let mismatchSubst (NamedDim v, d)-                | qualLeaf v `elem` new_dims =-                  case M.lookup v init_substs of-                    Just d'-                      | d' == d ->-                        return $ Just (qualLeaf v, SizeSubst d)-                    _ -> do-                      modify (qualLeaf v :)-                      return Nothing-              mismatchSubst _ = return Nothing--              (init_substs', sparams) =-                (`runState` mempty) $-                  M.fromList . catMaybes-                    <$> mapM-                      mismatchSubst-                      (snd $ anyDimOnMismatch pat_t' loopbody_t')--          -- Make sure that any of new_dims that are invariant will be-          -- replaced with the invariant size in the loop body.  Failure-          -- to do this can cause type annotations to still refer to-          -- new_dims.-          let dimToInit (v, SizeSubst d) =-                constrain v $ Size (Just d) (mkUsage loc "size of loop parameter")-              dimToInit _ =-                return ()-          mapM_ dimToInit $ M.toList init_substs'--          mergepat'' <- applySubst (`M.lookup` init_substs') <$> updateTypes mergepat'-          return (nubOrd sparams, mergepat'')--    -- First we do a basic check of the loop body to figure out which of-    -- the merge parameters are being consumed.  For this, we first need-    -- to check the merge pattern, which requires the (initial) merge-    -- expression.-    ---    -- Play a little with occurences to ensure it does not look like-    -- none of the merge variables are being used.-    ((sparams, mergepat', form', loopbody'), bodyflow) <--      case form of-        For i uboundexp -> do-          uboundexp' <- require "being the bound in a 'for' loop" anySignedType =<< checkExp uboundexp-          bound_t <- expTypeFully uboundexp'-          bindingIdent i bound_t $ \i' ->-            noUnique . bindingPat [] mergepat (Ascribed merge_t) $-              \mergepat' -> onlySelfAliasing $-                tapOccurences $ do-                  loopbody' <- noSizeEscape $ checkExp loopbody-                  (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'-                  return-                    ( sparams,-                      mergepat'',-                      For i' uboundexp',-                      loopbody'-                    )-        ForIn xpat e -> do-          (arr_t, _) <- newArrayType (srclocOf e) "e" 1-          e' <- unifies "being iterated in a 'for-in' loop" arr_t =<< checkExp e-          t <- expTypeFully e'-          case t of-            _-              | Just t' <- peelArray 1 t ->-                bindingPat [] xpat (Ascribed t') $ \xpat' ->-                  noUnique . bindingPat [] mergepat (Ascribed merge_t) $-                    \mergepat' -> onlySelfAliasing . tapOccurences $ do-                      loopbody' <- noSizeEscape $ checkExp loopbody-                      (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'-                      return-                        ( sparams,-                          mergepat'',-                          ForIn xpat' e',-                          loopbody'-                        )-              | otherwise ->-                typeError (srclocOf e) mempty $-                  "Iteratee of a for-in loop must be an array, but expression has type"-                    <+> ppr t-        While cond ->-          noUnique . bindingPat [] mergepat (Ascribed merge_t) $ \mergepat' ->-            onlySelfAliasing . tapOccurences $-              sequentially-                ( checkExp cond-                    >>= unifies "being the condition of a 'while' loop" (Scalar $ Prim Bool)-                )-                $ \cond' _ -> do-                  loopbody' <- noSizeEscape $ checkExp loopbody-                  (sparams, mergepat'') <- checkLoopReturnSize mergepat' loopbody'-                  return-                    ( sparams,-                      mergepat'',-                      While cond',-                      loopbody'-                    )--    mergepat'' <- do-      loopbody_t <- expTypeFully loopbody'-      convergePat mergepat' (allConsumed bodyflow) loopbody_t $-        mkUsage (srclocOf loopbody') "being (part of) the result of the loop body"--    let consumeMerge (Id _ (Info pt) ploc) mt-          | unique pt = consume ploc $ aliases mt-        consumeMerge (TuplePat pats _) t-          | Just ts <- isTupleRecord t =-            zipWithM_ consumeMerge pats ts-        consumeMerge (PatParens pat _) t =-          consumeMerge pat t-        consumeMerge (PatAscription pat _ _) t =-          consumeMerge pat t-        consumeMerge _ _ =-          return ()-    consumeMerge mergepat'' =<< expTypeFully mergeexp'--    -- dim handling (3)-    let sparams_anydim = M.fromList $ zip sparams $ repeat $ SizeSubst $ AnyDim Nothing-        loopt_anydims =-          applySubst (`M.lookup` sparams_anydim) $-            patternType mergepat''-    (merge_t', _) <--      instantiateEmptyArrayDims loc "loopres" Nonrigid $ toStruct loopt_anydims-    mergeexp_t <- toStruct <$> expTypeFully mergeexp'-    onFailure (CheckingLoopInitial (toStruct loopt_anydims) mergeexp_t) $-      unify-        (mkUsage (srclocOf mergeexp') "matching initial loop values to pattern")-        merge_t'-        mergeexp_t--    (loopt, retext) <- instantiateDimsInType loc RigidLoop loopt_anydims-    -- We set all of the uniqueness to be unique.  This is intentional,-    -- and matches what happens for function calls.  Those arrays that-    -- really *cannot* be consumed will alias something unconsumable,-    -- and will be caught that way.-    let bound_here = patNames mergepat'' <> S.fromList sparams <> form_bound-        form_bound =-          case form' of-            For v _ -> S.singleton $ identName v-            ForIn forpat _ -> patNames forpat-            While {} -> mempty-        loopt' =-          second (`S.difference` S.map AliasBound bound_here) $-            loopt `setUniqueness` Unique--    -- Eliminate those new_dims that turned into sparams so it won't-    -- look like we have ambiguous sizes lying around.-    modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` sparams--    return $-      AppExp-        (DoLoop sparams mergepat'' mergeexp' form' loopbody' loc)-        (Info $ AppRes loopt' retext)-  where-    anyTheseSizes to_hide = first onDim-      where-        onDim (NamedDim (QualName _ v))-          | v `elem` to_hide = AnyDim Nothing-        onDim d = d--    convergePat pat body_cons body_t body_loc = do-      let consumed_merge = patNames pat `S.intersection` body_cons--          uniquePat (Wildcard (Info t) wloc) =-            Wildcard (Info $ t `setUniqueness` Nonunique) wloc-          uniquePat (PatParens p ploc) =-            PatParens (uniquePat p) ploc-          uniquePat (Id name (Info t) iloc)-            | name `S.member` consumed_merge =-              let t' = t `setUniqueness` Unique `setAliases` mempty-               in Id name (Info t') iloc-            | otherwise =-              let t' = t `setUniqueness` Nonunique-               in Id name (Info t') iloc-          uniquePat (TuplePat pats ploc) =-            TuplePat (map uniquePat pats) ploc-          uniquePat (RecordPat fs ploc) =-            RecordPat (map (fmap uniquePat) fs) ploc-          uniquePat (PatAscription p t ploc) =-            PatAscription p t ploc-          uniquePat p@PatLit {} = p-          uniquePat (PatConstr n t ps ploc) =-            PatConstr n t (map uniquePat ps) ploc--          -- Make the pattern unique where needed.-          pat' = uniquePat pat--      pat_t <- normTypeFully $ patternType pat'-      unless (toStructural body_t `subtypeOf` toStructural pat_t) $-        unexpectedType (srclocOf body_loc) (toStruct body_t) [toStruct pat_t]--      -- Check that the new values of consumed merge parameters do not-      -- alias something bound outside the loop, AND that anything-      -- returned for a unique merge parameter does not alias anything-      -- else returned.  We also update the aliases for the pattern.-      bound_outside <- asks $ S.fromList . M.keys . scopeVtable . termScope-      let combAliases t1 t2 =-            case t1 of-              Scalar Record {} -> t1-              _ -> t1 `addAliases` (<> aliases t2)--          checkMergeReturn (Id pat_v (Info pat_v_t) patloc) t-            | unique pat_v_t,-              v : _ <--                S.toList $-                  S.map aliasVar (aliases t) `S.intersection` bound_outside =-              lift $-                typeError loc mempty $-                  "Return value for loop parameter"-                    <+> pquote (pprName pat_v)-                    <+> "aliases"-                    <+> pprName v <> "."-            | otherwise = do-              (cons, obs) <- get-              unless (S.null $ aliases t `S.intersection` cons) $-                lift $-                  typeError loc mempty $-                    "Return value for loop parameter"-                      <+> pquote (pprName pat_v)-                      <+> "aliases other consumed loop parameter."-              when-                ( unique pat_v_t-                    && not (S.null (aliases t `S.intersection` (cons <> obs)))-                )-                $ lift $-                  typeError loc mempty $-                    "Return value for consuming loop parameter"-                      <+> pquote (pprName pat_v)-                      <+> "aliases previously returned value."-              if unique pat_v_t-                then put (cons <> aliases t, obs)-                else put (cons, obs <> aliases t)--              return $ Id pat_v (Info (combAliases pat_v_t t)) patloc-          checkMergeReturn (Wildcard (Info pat_v_t) patloc) t =-            return $ Wildcard (Info (combAliases pat_v_t t)) patloc-          checkMergeReturn (PatParens p _) t =-            checkMergeReturn p t-          checkMergeReturn (PatAscription p _ _) t =-            checkMergeReturn p t-          checkMergeReturn (RecordPat pfs patloc) (Scalar (Record tfs)) =-            RecordPat . M.toList <$> sequence pfs' <*> pure patloc-            where-              pfs' =-                M.intersectionWith-                  checkMergeReturn-                  (M.fromList pfs)-                  tfs-          checkMergeReturn (TuplePat pats patloc) t-            | Just ts <- isTupleRecord t =-              TuplePat-                <$> zipWithM checkMergeReturn pats ts-                <*> pure patloc-          checkMergeReturn p _ =-            return p--      (pat'', (pat_cons, _)) <--        runStateT (checkMergeReturn pat' body_t) (mempty, mempty)--      let body_cons' = body_cons <> S.map aliasVar pat_cons-      if body_cons' == body_cons && patternType pat'' == patternType pat-        then return pat'-        else convergePat pat'' body_cons' body_t body_loc-checkExp (Constr name es NoInfo loc) = do-  t <- newTypeVar loc "t"-  es' <- mapM checkExp es-  ets <- mapM expTypeFully es'-  mustHaveConstr (mkUsage loc "use of constructor") name t (toStruct <$> ets)-  -- A sum value aliases *anything* that went into its construction.-  let als = foldMap aliases ets-  return $ Constr name es' (Info $ fromStruct t `addAliases` (<> als)) loc-checkExp (AppExp (Match e cs loc) _) =-  sequentially (checkExp e) $ \e' _ -> do-    mt <- expTypeFully e'-    (cs', t, retext) <- checkCases mt cs-    zeroOrderType-      (mkUsage loc "being returned 'match'")-      "type returned from pattern match"-      t-    return $ AppExp (Match e' cs' loc) (Info $ AppRes t retext)-checkExp (Attr info e loc) =-  Attr info <$> checkExp e <*> pure loc--checkCases ::-  PatType ->-  NE.NonEmpty (CaseBase NoInfo Name) ->-  TermTypeM (NE.NonEmpty (CaseBase Info VName), PatType, [VName])-checkCases mt rest_cs =-  case NE.uncons rest_cs of-    (c, Nothing) -> do-      (c', t, retext) <- checkCase mt c-      return (c' NE.:| [], t, retext)-    (c, Just cs) -> do-      (((c', c_t, _), (cs', cs_t, _)), dflow) <--        tapOccurences $ checkCase mt c `alternative` checkCases mt cs-      (brancht, retext) <- unifyBranchTypes (srclocOf c) c_t cs_t-      let t =-            addAliases-              brancht-              (`S.difference` S.map AliasBound (allConsumed dflow))-      return (NE.cons c' cs', t, retext)--checkCase ::-  PatType ->-  CaseBase NoInfo Name ->-  TermTypeM (CaseBase Info VName, PatType, [VName])-checkCase mt (CasePat p e loc) =-  bindingPat [] p (Ascribed mt) $ \p' -> do-    e' <- checkExp e-    (t, retext) <- unscopeType loc (patternMap p') =<< expTypeFully e'-    return (CasePat p' e' loc, t, retext)---- | An unmatched pattern. Used in in the generation of--- unmatched pattern warnings by the type checker.-data Unmatched p-  = UnmatchedNum p [PatLit]-  | UnmatchedBool p-  | UnmatchedConstr p-  | Unmatched p-  deriving (Functor, Show)--instance Pretty (Unmatched (PatBase Info VName)) where-  ppr um = case um of-    (UnmatchedNum p nums) -> ppr' p <+> "where p is not one of" <+> ppr nums-    (UnmatchedBool p) -> ppr' p-    (UnmatchedConstr p) -> ppr' p-    (Unmatched p) -> ppr' p-    where-      ppr' (PatAscription p t _) = ppr p <> ":" <+> ppr t-      ppr' (PatParens p _) = parens $ ppr' p-      ppr' (Id v _ _) = pprName v-      ppr' (TuplePat pats _) = parens $ commasep $ map ppr' pats-      ppr' (RecordPat fs _) = braces $ commasep $ map ppField fs-        where-          ppField (name, t) = text (nameToString name) <> equals <> ppr' t-      ppr' Wildcard {} = "_"-      ppr' (PatLit e _ _) = ppr e-      ppr' (PatConstr n _ ps _) = "#" <> ppr n <+> sep (map ppr' ps)--checkUnmatched :: Exp -> TermTypeM ()-checkUnmatched e = void $ checkUnmatched' e >> astMap tv e-  where-    checkUnmatched' (AppExp (Match _ cs loc) _) =-      let ps = fmap (\(CasePat p _ _) -> p) cs-       in case unmatched $ NE.toList ps of-            [] -> return ()-            ps' ->-              typeError loc mempty $-                "Unmatched cases in match expression:"-                  </> indent 2 (stack (map ppr ps'))-    checkUnmatched' _ = return ()-    tv =-      ASTMapper-        { mapOnExp =-            \e' -> checkUnmatched' e' >> return e',-          mapOnName = pure,-          mapOnQualName = pure,-          mapOnStructType = pure,-          mapOnPatType = pure-        }--checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident-checkIdent (Ident name _ loc) = do-  (QualName _ name', vt) <- lookupVar loc (qualName name)-  return $ Ident name' (Info vt) loc--checkSlice :: UncheckedSlice -> TermTypeM Slice-checkSlice = mapM checkDimIndex-  where-    checkDimIndex (DimFix i) =-      DimFix <$> (require "use as index" anySignedType =<< checkExp i)-    checkDimIndex (DimSlice i j s) =-      DimSlice <$> check i <*> check j <*> check s--    check =-      maybe (return Nothing) $-        fmap Just . unifies "use as index" (Scalar $ Prim $ Signed Int64) <=< checkExp---- The number of dimensions affected by this slice (so the minimum--- rank of the array we are slicing).-sliceDims :: Slice -> Int-sliceDims = length--sequentially :: TermTypeM a -> (a -> Occurences -> TermTypeM b) -> TermTypeM b-sequentially m1 m2 = do-  (a, m1flow) <- collectOccurences m1-  (b, m2flow) <- collectOccurences $ m2 a m1flow-  occur $ m1flow `seqOccurences` m2flow-  return b--type Arg = (Exp, PatType, Occurences, SrcLoc)--argExp :: Arg -> Exp-argExp (e, _, _, _) = e--argType :: Arg -> PatType-argType (_, t, _, _) = t--checkArg :: UncheckedExp -> TermTypeM Arg-checkArg arg = do-  (arg', dflow) <- collectOccurences $ checkExp arg-  arg_t <- expType arg'-  return (arg', arg_t, dflow, srclocOf arg')--instantiateDimsInType ::-  SrcLoc ->-  RigidSource ->-  TypeBase (DimDecl VName) als ->-  TermTypeM (TypeBase (DimDecl VName) als, [VName])-instantiateDimsInType tloc rsrc =-  instantiateEmptyArrayDims tloc "d" $ Rigid rsrc--instantiateDimsInReturnType ::-  SrcLoc ->-  Maybe (QualName VName) ->-  TypeBase (DimDecl VName) als ->-  TermTypeM (TypeBase (DimDecl VName) als, [VName])-instantiateDimsInReturnType tloc fname =-  instantiateEmptyArrayDims tloc "ret" $ Rigid $ RigidRet fname---- Some information about the function/operator we are trying to--- apply, and how many arguments it has previously accepted.  Used for--- generating nicer type errors.-type ApplyOp = (Maybe (QualName VName), Int)--checkApply ::-  SrcLoc ->-  ApplyOp ->-  PatType ->-  Arg ->-  TermTypeM (PatType, PatType, Maybe VName, [VName])-checkApply-  loc-  (fname, _)-  (Scalar (Arrow as pname tp1 tp2))-  (argexp, argtype, dflow, argloc) =-    onFailure (CheckingApply fname argexp (toStruct tp1) (toStruct argtype)) $ do-      expect (mkUsage argloc "use as function argument") (toStruct tp1) (toStruct argtype)--      -- Perform substitutions of instantiated variables in the types.-      tp1' <- normTypeFully tp1-      (tp2', ext) <- instantiateDimsInReturnType loc fname =<< normTypeFully tp2-      argtype' <- normTypeFully argtype--      -- Check whether this would produce an impossible return type.-      let (_, tp2_paramdims, _) = dimUses $ toStruct tp2'-      case filter (`S.member` tp2_paramdims) ext of-        [] -> return ()-        ext_paramdims -> do-          let onDim (NamedDim qn)-                | qualLeaf qn `elem` ext_paramdims = AnyDim $ Just $ qualLeaf qn-              onDim d = d-          typeError loc mempty $-            "Anonymous size would appear in function parameter of return type:"-              </> indent 2 (ppr (first onDim tp2'))-              </> textwrap "This is usually because a higher-order function is used with functional arguments that return anonymous sizes, which are then used as parameters of other function arguments."--      occur [observation as loc]--      checkOccurences dflow--      case anyConsumption dflow of-        Just c ->-          let msg = "type of expression with consumption at " ++ locStr (location c)-           in zeroOrderType (mkUsage argloc "potential consumption in expression") msg tp1-        _ -> return ()--      occurs <- (dflow `seqOccurences`) <$> consumeArg argloc argtype' (diet tp1')--      checkIfConsumable loc $ S.map AliasBound $ allConsumed occurs-      occur occurs--      (argext, parsubst) <--        case pname of-          Named pname' -> do-            (d, argext) <- sizeSubst tp1' argexp-            return-              ( argext,-                (`M.lookup` M.singleton pname' (SizeSubst d))-              )-          _ -> return (Nothing, const Nothing)-      let tp2'' = applySubst parsubst $ returnType tp2' (diet tp1') argtype'--      return (tp1', tp2'', argext, ext)-    where-      sizeSubst (Scalar (Prim (Signed Int64))) e = dimFromArg fname e-      sizeSubst _ _ = return (AnyDim Nothing, Nothing)-checkApply loc fname tfun@(Scalar TypeVar {}) arg = do-  tv <- newTypeVar loc "b"-  -- Change the uniqueness of the argument type because we never want-  -- to infer that a function is consuming.-  unify (mkUsage loc "use as function") (toStruct tfun) $-    Scalar $ Arrow mempty Unnamed (toStruct (argType arg) `setUniqueness` Nonunique) tv-  tfun' <- normPatType tfun-  checkApply loc fname tfun' arg-checkApply loc (fname, prev_applied) ftype (argexp, _, _, _) = do-  let fname' = maybe "expression" (pquote . ppr) fname--  typeError loc mempty $-    if prev_applied == 0-      then-        "Cannot apply" <+> fname' <+> "as function, as it has type:"-          </> indent 2 (ppr ftype)-      else-        "Cannot apply" <+> fname' <+> "to argument #" <> ppr (prev_applied + 1)-          <+> pquote (shorten $ pretty $ flatten $ ppr argexp) <> ","-          <+/> "as"-          <+> fname'-          <+> "only takes"-          <+> ppr prev_applied-          <+> arguments <> "."-  where-    arguments-      | prev_applied == 1 = "argument"-      | otherwise = "arguments"--isInt64 :: Exp -> Maybe Int64-isInt64 (Literal (SignedValue (Int64Value k')) _) = Just $ fromIntegral k'-isInt64 (IntLit k' _ _) = Just $ fromInteger k'-isInt64 (Negate x _) = negate <$> isInt64 x-isInt64 _ = Nothing--maybeDimFromExp :: Exp -> Maybe (DimDecl VName)-maybeDimFromExp (Var v _ _) = Just $ NamedDim v-maybeDimFromExp (Parens e _) = maybeDimFromExp e-maybeDimFromExp (QualParens _ e _) = maybeDimFromExp e-maybeDimFromExp e = ConstDim . fromIntegral <$> isInt64 e--dimFromExp :: (Exp -> SizeSource) -> Exp -> TermTypeM (DimDecl VName, Maybe VName)-dimFromExp rf (Parens e _) = dimFromExp rf e-dimFromExp rf (QualParens _ e _) = dimFromExp rf e-dimFromExp rf e-  | Just d <- maybeDimFromExp e =-    return (d, Nothing)-  | otherwise =-    extSize (srclocOf e) $ rf e--dimFromArg :: Maybe (QualName VName) -> Exp -> TermTypeM (DimDecl VName, Maybe VName)-dimFromArg fname = dimFromExp $ SourceArg (FName fname) . bareExp---- | @returnType ret_type arg_diet arg_type@ gives result of applying--- an argument the given types to a function with the given return--- type, consuming the argument with the given diet.-returnType ::-  PatType ->-  Diet ->-  PatType ->-  PatType-returnType (Array _ Unique et shape) _ _ =-  Array mempty Unique et shape-returnType (Array als Nonunique et shape) d arg =-  Array (als <> arg_als) Unique et shape -- Intentional!-  where-    arg_als = aliases $ maskAliases arg d-returnType (Scalar (Record fs)) d arg =-  Scalar $ Record $ fmap (\et -> returnType et d arg) fs-returnType (Scalar (Prim t)) _ _ =-  Scalar $ Prim t-returnType (Scalar (TypeVar _ Unique t targs)) _ _ =-  Scalar $ TypeVar mempty Unique t targs-returnType (Scalar (TypeVar als Nonunique t targs)) d arg =-  Scalar $ TypeVar (als <> arg_als) Unique t targs -- Intentional!-  where-    arg_als = aliases $ maskAliases arg d-returnType (Scalar (Arrow old_als v t1 t2)) d arg =-  Scalar $ Arrow als v (t1 `setAliases` mempty) (t2 `setAliases` als)-  where-    -- Make sure to propagate the aliases of an existing closure.-    als = old_als <> aliases (maskAliases arg d)-returnType (Scalar (Sum cs)) d arg =-  Scalar $ Sum $ (fmap . fmap) (\et -> returnType et d arg) cs---- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from--- the parts of @t@ that are denoted as consumed by the 'Diet' @d@.-maskAliases ::-  Monoid as =>-  TypeBase shape as ->-  Diet ->-  TypeBase shape as-maskAliases t Consume = t `setAliases` mempty-maskAliases t Observe = t-maskAliases (Scalar (Record ets)) (RecordDiet ds) =-  Scalar $ Record $ M.intersectionWith maskAliases ets ds-maskAliases t FuncDiet {} = t-maskAliases _ _ = error "Invalid arguments passed to maskAliases."--consumeArg :: SrcLoc -> PatType -> Diet -> TermTypeM [Occurence]-consumeArg loc (Scalar (Record ets)) (RecordDiet ds) =-  concat . M.elems <$> traverse (uncurry $ consumeArg loc) (M.intersectionWith (,) ets ds)-consumeArg loc (Array _ Nonunique _ _) Consume =-  typeError loc mempty "Consuming parameter passed non-unique argument."-consumeArg loc (Scalar (TypeVar _ Nonunique _ _)) Consume =-  typeError loc mempty "Consuming parameter passed non-unique argument."-consumeArg loc (Scalar (Arrow _ _ t1 _)) (FuncDiet d _)-  | not $ contravariantArg t1 d =-    typeError loc mempty "Non-consuming higher-order parameter passed consuming argument."-  where-    contravariantArg (Array _ Unique _ _) Observe =-      False-    contravariantArg (Scalar (TypeVar _ Unique _ _)) Observe =-      False-    contravariantArg (Scalar (Record ets)) (RecordDiet ds) =-      and (M.intersectionWith contravariantArg ets ds)-    contravariantArg (Scalar (Arrow _ _ tp tr)) (FuncDiet dp dr) =-      contravariantArg tp dp && contravariantArg tr dr-    contravariantArg _ _ =-      True-consumeArg loc at Consume = return [consumption (aliases at) loc]-consumeArg loc at _ = return [observation (aliases at) loc]---- | Type-check a single expression in isolation.  This expression may--- turn out to be polymorphic, in which case the list of type--- parameters will be non-empty.-checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp)-checkOneExp e = fmap fst . runTermTypeM $ do-  e' <- checkExp e-  let t = toStruct $ typeOf e'-  (tparams, _, _, _) <--    letGeneralise (nameFromString "<exp>") (srclocOf e) [] [] t-  fixOverloadedTypes $ typeVars t-  e'' <- updateTypes e'-  checkUnmatched e''-  causalityCheck e''-  literalOverflowCheck e''-  return (tparams, e'')---- Verify that all sum type constructors and empty array literals have--- a size that is known (rigid or a type parameter).  This is to--- ensure that we can actually determine their shape at run-time.-causalityCheck :: Exp -> TermTypeM ()-causalityCheck binding_body = do-  constraints <- getConstraints--  let checkCausality what known t loc-        | (d, dloc) : _ <--            mapMaybe (unknown constraints known) $-              S.toList $ typeDimNames $ toStruct t =-          Just $ lift $ causality what loc d dloc t-        | otherwise = Nothing--      checkParamCausality known p =-        checkCausality (ppr p) known (patternType p) (srclocOf p)--      onExp ::-        S.Set VName ->-        Exp ->-        StateT (S.Set VName) (Either TypeError) Exp--      onExp known (Var v (Info t) loc)-        | Just bad <- checkCausality (pquote (ppr v)) known t loc =-          bad-      onExp known (ProjectSection _ (Info t) loc)-        | Just bad <- checkCausality "projection section" known t loc =-          bad-      onExp known (IndexSection _ (Info t) loc)-        | Just bad <- checkCausality "projection section" known t loc =-          bad-      onExp known (OpSectionRight _ (Info t) _ _ _ loc)-        | Just bad <- checkCausality "operator section" known t loc =-          bad-      onExp known (OpSectionLeft _ (Info t) _ _ _ loc)-        | Just bad <- checkCausality "operator section" known t loc =-          bad-      onExp known (ArrayLit [] (Info t) loc)-        | Just bad <- checkCausality "empty array" known t loc =-          bad-      onExp known (Lambda params _ _ _ _)-        | bad : _ <- mapMaybe (checkParamCausality known) params =-          bad-      onExp known e@(AppExp (LetPat _ _ bindee_e body_e _) (Info res)) = do-        sequencePoint known bindee_e body_e $ appResExt res-        return e-      onExp known e@(AppExp (Apply f arg (Info (_, p)) _) (Info res)) = do-        sequencePoint known arg f $ maybeToList p ++ appResExt res-        return e-      onExp-        known-        e@(AppExp (BinOp (f, floc) ft (x, Info (_, xp)) (y, Info (_, yp)) _) (Info res)) = do-          args_known <--            lift $-              execStateT (sequencePoint known x y $ catMaybes [xp, yp]) mempty-          void $ onExp (args_known <> known) (Var f ft floc)-          modify ((args_known <> S.fromList (appResExt res)) <>)-          return e-      onExp known e@(AppExp e' (Info res)) = do-        recurse known e'-        modify (<> S.fromList (appResExt res))-        pure e-      onExp known e = do-        recurse known e-        pure e--      recurse known = void . astMap mapper-        where-          mapper = identityMapper {mapOnExp = onExp known}--      sequencePoint known x y ext = do-        new_known <- lift $ execStateT (onExp known x) mempty-        void $ onExp (new_known <> known) y-        modify ((new_known <> S.fromList ext) <>)--  either throwError (const $ return ()) $-    evalStateT (onExp mempty binding_body) mempty-  where-    unknown constraints known v = do-      guard $ v `S.notMember` known-      loc <- unknowable constraints v-      return (v, loc)--    unknowable constraints v =-      case snd <$> M.lookup v constraints of-        Just (UnknowableSize loc _) -> Just loc-        _ -> Nothing--    causality what loc d dloc t =-      Left $-        TypeError loc mempty . withIndexLink "causality-check" $-          "Causality check: size" <+/> pquote (pprName d)-            <+/> "needed for type of"-            <+> what <> colon-            </> indent 2 (ppr t)-            </> "But"-            <+> pquote (pprName d)-            <+> "is computed at"-            <+/> text (locStrRel loc dloc) <> "."-            </> ""-            </> "Hint:"-            <+> align-              ( textwrap "Bind the expression producing" <+> pquote (pprName d)-                  <+> "with 'let' beforehand."-              )---- | Traverse the expression, emitting warnings if any of the literals overflow--- their inferred types------ Note: currently unable to detect float underflow (such as 1e-400 -> 0)-literalOverflowCheck :: Exp -> TermTypeM ()-literalOverflowCheck = void . check-  where-    check e@(IntLit x ty loc) =-      e <$ case ty of-        Info (Scalar (Prim t)) -> warnBounds (inBoundsI x t) x t loc-        _ -> error "Inferred type of int literal is not a number"-    check e@(FloatLit x ty loc) =-      e <$ case ty of-        Info (Scalar (Prim (FloatType t))) -> warnBounds (inBoundsF x t) x t loc-        _ -> error "Inferred type of float literal is not a float"-    check e@(Negate (IntLit x ty loc1) loc2) =-      e <$ case ty of-        Info (Scalar (Prim t)) -> warnBounds (inBoundsI (- x) t) (- x) t (loc1 <> loc2)-        _ -> error "Inferred type of int literal is not a number"-    check e = astMap identityMapper {mapOnExp = check} e-    bitWidth ty = 8 * intByteSize ty :: Int-    inBoundsI x (Signed t) = x >= -2 ^ (bitWidth t - 1) && x < 2 ^ (bitWidth t - 1)-    inBoundsI x (Unsigned t) = x >= 0 && x < 2 ^ bitWidth t-    inBoundsI x (FloatType Float16) = not $ isInfinite (fromIntegral x :: Half)-    inBoundsI x (FloatType Float32) = not $ isInfinite (fromIntegral x :: Float)-    inBoundsI x (FloatType Float64) = not $ isInfinite (fromIntegral x :: Double)-    inBoundsI _ Bool = error "Inferred type of int literal is not a number"-    inBoundsF x Float16 = not $ isInfinite (realToFrac x :: Float)-    inBoundsF x Float32 = not $ isInfinite (realToFrac x :: Float)-    inBoundsF x Float64 = not $ isInfinite x-    warnBounds inBounds x ty loc =-      unless inBounds $-        typeError loc mempty $-          "Literal " <> ppr x-            <> " out of bounds for inferred type "-            <> ppr ty-            <> "."---- | Type-check a top-level (or module-level) function definition.--- Despite the name, this is also used for checking constant--- definitions, by treating them as 0-ary functions.-checkFunDef ::-  ( Name,-    Maybe UncheckedTypeExp,-    [UncheckedTypeParam],-    [UncheckedPat],-    UncheckedExp,-    SrcLoc-  ) ->-  TypeM-    ( VName,-      [TypeParam],-      [Pat],-      Maybe (TypeExp VName),-      StructType,-      [VName],-      Exp-    )-checkFunDef (fname, maybe_retdecl, tparams, params, body, loc) =-  fmap fst $-    runTermTypeM $ do-      (tparams', params', maybe_retdecl', rettype', retext, body') <--        checkBinding (fname, maybe_retdecl, tparams, params, body, loc)--      -- Since this is a top-level function, we also resolve overloaded-      -- types, using either defaults or complaining about ambiguities.-      fixOverloadedTypes $-        typeVars rettype' <> foldMap (typeVars . patternType) params'--      -- Then replace all inferred types in the body and parameters.-      body'' <- updateTypes body'-      params'' <- updateTypes params'-      maybe_retdecl'' <- traverse updateTypes maybe_retdecl'-      rettype'' <- normTypeFully rettype'--      -- Check if pattern matches are exhaustive and yield-      -- errors if not.-      checkUnmatched body''--      -- Check if the function body can actually be evaluated.-      causalityCheck body''--      literalOverflowCheck body''--      bindSpaced [(Term, fname)] $ do-        fname' <- checkName Term fname loc-        when (nameToString fname `elem` doNotShadow) $-          typeError loc mempty $-            "The" <+> pprName fname <+> "operator may not be redefined."--        return (fname', tparams', params'', maybe_retdecl'', rettype'', retext, body'')---- | This is "fixing" as in "setting them", not "correcting them".  We--- only make very conservative fixing.-fixOverloadedTypes :: Names -> TermTypeM ()-fixOverloadedTypes tyvars_at_toplevel =-  getConstraints >>= mapM_ fixOverloaded . M.toList . M.map snd-  where-    fixOverloaded (v, Overloaded ots usage)-      | Signed Int32 `elem` ots = do-        unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $-          Scalar $ Prim $ Signed Int32-        when (v `S.member` tyvars_at_toplevel) $-          warn usage "Defaulting ambiguous type to i32."-      | FloatType Float64 `elem` ots = do-        unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $-          Scalar $ Prim $ FloatType Float64-        when (v `S.member` tyvars_at_toplevel) $-          warn usage "Defaulting ambiguous type to f64."-      | otherwise =-        typeError usage mempty $-          "Type is ambiguous (could be one of" <+> commasep (map ppr ots) <> ")."-            </> "Add a type annotation to disambiguate the type."-    fixOverloaded (_, NoConstraint _ usage) =-      typeError usage mempty $-        "Type of expression is ambiguous."-          </> "Add a type annotation to disambiguate the type."-    fixOverloaded (_, Equality usage) =-      typeError usage mempty $-        "Type is ambiguous (must be equality type)."-          </> "Add a type annotation to disambiguate the type."-    fixOverloaded (_, HasFields fs usage) =-      typeError usage mempty $-        "Type is ambiguous.  Must be record with fields:"-          </> indent 2 (stack $ map field $ M.toList fs)-          </> "Add a type annotation to disambiguate the type."-      where-        field (l, t) = ppr l <> colon <+> align (ppr t)-    fixOverloaded (_, HasConstrs cs usage) =-      typeError usage mempty $-        "Type is ambiguous (must be a sum type with constructors:"-          <+> ppr (Sum cs) <> ")."-          </> "Add a type annotation to disambiguate the type."-    fixOverloaded (v, Size Nothing usage) =-      typeError usage mempty $ "Size" <+> pquote (pprName v) <+> "is ambiguous.\n"-    fixOverloaded _ = return ()--hiddenParamNames :: [Pat] -> Names-hiddenParamNames params = hidden-  where-    param_all_names = mconcat $ map patNames params-    named (Named x, _) = Just x-    named (Unnamed, _) = Nothing-    param_names =-      S.fromList $ mapMaybe (named . patternParam) params-    hidden = param_all_names `S.difference` param_names--inferredReturnType :: SrcLoc -> [Pat] -> PatType -> TermTypeM StructType-inferredReturnType loc params t =-  -- The inferred type may refer to names that are bound by the-  -- parameter patterns, but which will not be visible in the type.-  -- These we must turn into fresh type variables, which will be-  -- existential in the return type.-  fmap (toStruct . fst) $-    unscopeType-      loc-      (M.filterWithKey (const . (`S.member` hidden)) $ foldMap patternMap params)-      $ inferReturnUniqueness params t-  where-    hidden = hiddenParamNames params--checkBinding ::-  ( Name,-    Maybe UncheckedTypeExp,-    [UncheckedTypeParam],-    [UncheckedPat],-    UncheckedExp,-    SrcLoc-  ) ->-  TermTypeM-    ( [TypeParam],-      [Pat],-      Maybe (TypeExp VName),-      StructType,-      [VName],-      Exp-    )-checkBinding (fname, maybe_retdecl, tparams, params, body, loc) =-  noUnique . incLevel . bindingParams tparams params $ \tparams' params' -> do-    when (null params && any isSizeParam tparams) $-      typeError-        loc-        mempty-        "Size parameters are only allowed on bindings that also have value parameters."--    maybe_retdecl' <- forM maybe_retdecl $ \retdecl -> do-      (retdecl', ret_nodims, _) <- checkTypeExp retdecl-      (ret, _) <- instantiateEmptyArrayDims loc "funret" Nonrigid ret_nodims-      return (retdecl', ret)--    body' <--      checkFunBody-        params'-        body-        (snd <$> maybe_retdecl')-        (maybe loc srclocOf maybe_retdecl)--    params'' <- mapM updateTypes params'-    body_t <- expTypeFully body'--    (maybe_retdecl'', rettype) <- case maybe_retdecl' of-      Just (retdecl', ret) -> do-        let rettype_structural = toStructural ret-        checkReturnAlias rettype_structural params'' body_t--        when (null params) $ nothingMustBeUnique loc rettype_structural--        ret' <- normTypeFully ret--        return (Just retdecl', ret')-      Nothing-        | null params ->-          return (Nothing, toStruct $ body_t `setUniqueness` Nonunique)-        | otherwise -> do-          body_t' <- inferredReturnType loc params'' body_t-          return (Nothing, body_t')--    verifyFunctionParams (Just fname) params''--    (tparams'', params''', rettype'', retext) <--      letGeneralise fname loc tparams' params'' rettype--    checkGlobalAliases params'' body_t loc--    return (tparams'', params''', maybe_retdecl'', rettype'', retext, body')-  where-    checkReturnAlias rettp params' =-      foldM_ (checkReturnAlias' params') S.empty . returnAliasing rettp-    checkReturnAlias' params' seen (Unique, names)-      | any (`S.member` S.map snd seen) $ S.toList names =-        uniqueReturnAliased fname loc-      | otherwise = do-        notAliasingParam params' names-        return $ seen `S.union` tag Unique names-    checkReturnAlias' _ seen (Nonunique, names)-      | any (`S.member` seen) $ S.toList $ tag Unique names =-        uniqueReturnAliased fname loc-      | otherwise = return $ seen `S.union` tag Nonunique names--    notAliasingParam params' names =-      forM_ params' $ \p ->-        let consumedNonunique p' =-              not (unique $ unInfo $ identType p') && (identName p' `S.member` names)-         in case find consumedNonunique $ S.toList $ patIdents p of-              Just p' ->-                returnAliased fname (baseName $ identName p') loc-              Nothing ->-                return ()--    tag u = S.map (u,)--    returnAliasing (Scalar (Record ets1)) (Scalar (Record ets2)) =-      concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2-    returnAliasing expected got =-      [(uniqueness expected, S.map aliasVar $ aliases got)]---- | Extract all the shape names that occur in positive position--- (roughly, left side of an arrow) in a given type.-typeDimNamesPos :: TypeBase (DimDecl VName) als -> S.Set VName-typeDimNamesPos (Scalar (Arrow _ _ t1 t2)) = onParam t1 <> typeDimNamesPos t2-  where-    onParam :: TypeBase (DimDecl VName) als -> S.Set VName-    onParam (Scalar Arrow {}) = mempty-    onParam (Scalar (Record fs)) = mconcat $ map onParam $ M.elems fs-    onParam (Scalar (TypeVar _ _ _ targs)) = mconcat $ map onTypeArg targs-    onParam t = typeDimNames t-    onTypeArg (TypeArgDim (NamedDim d) _) = S.singleton $ qualLeaf d-    onTypeArg (TypeArgDim _ _) = mempty-    onTypeArg (TypeArgType t _) = onParam t-typeDimNamesPos _ = mempty--checkGlobalAliases :: [Pat] -> PatType -> SrcLoc -> TermTypeM ()-checkGlobalAliases params body_t loc = do-  vtable <- asks $ scopeVtable . termScope-  let isLocal v = case v `M.lookup` vtable of-        Just (BoundV Local _ _) -> True-        _ -> False-  let als =-        filter (not . isLocal) $-          S.toList $-            boundArrayAliases body_t-              `S.difference` foldMap patNames params-  case als of-    v : _-      | not $ null params ->-        typeError loc mempty $-          "Function result aliases the free variable "-            <> pquote (pprName v)-            <> "."-            </> "Use" <+> pquote "copy" <+> "to break the aliasing."-    _ ->-      return ()--inferReturnUniqueness :: [Pat] -> PatType -> PatType-inferReturnUniqueness params t =-  let forbidden = aliasesMultipleTimes t-      uniques = uniqueParamNames params-      delve (Scalar (Record fs)) =-        Scalar $ Record $ M.map delve fs-      delve t'-        | all (`S.member` uniques) (boundArrayAliases t'),-          not $ any ((`S.member` forbidden) . aliasVar) (aliases t') =-          t'-        | otherwise =-          t' `setUniqueness` Nonunique-   in delve t---- An alias inhibits uniqueness if it is used in disjoint values.-aliasesMultipleTimes :: PatType -> Names-aliasesMultipleTimes = S.fromList . map fst . filter ((> 1) . snd) . M.toList . delve-  where-    delve (Scalar (Record fs)) =-      foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs-    delve t =-      M.fromList $ zip (map aliasVar $ S.toList (aliases t)) $ repeat (1 :: Int)--uniqueParamNames :: [Pat] -> Names-uniqueParamNames =-  S.map identName-    . S.filter (unique . unInfo . identType)-    . foldMap patIdents--boundArrayAliases :: PatType -> S.Set VName-boundArrayAliases (Array als _ _ _) = boundAliases als-boundArrayAliases (Scalar Prim {}) = mempty-boundArrayAliases (Scalar (Record fs)) = foldMap boundArrayAliases fs-boundArrayAliases (Scalar (TypeVar als _ _ _)) = boundAliases als-boundArrayAliases (Scalar Arrow {}) = mempty-boundArrayAliases (Scalar (Sum fs)) =-  mconcat $ concatMap (map boundArrayAliases) $ M.elems fs---- | The set of in-scope variables that are being aliased.-boundAliases :: Aliasing -> S.Set VName-boundAliases = S.map aliasVar . S.filter bound-  where-    bound AliasBound {} = True-    bound AliasFree {} = False--nothingMustBeUnique :: SrcLoc -> TypeBase () () -> TermTypeM ()-nothingMustBeUnique loc = check-  where-    check (Array _ Unique _ _) = bad-    check (Scalar (TypeVar _ Unique _ _)) = bad-    check (Scalar (Record fs)) = mapM_ check fs-    check (Scalar (Sum fs)) = mapM_ (mapM_ check) fs-    check _ = return ()-    bad = typeError loc mempty "A top-level constant cannot have a unique type."---- | Verify certain restrictions on function parameters, and bail out--- on dubious constructions.------ These restrictions apply to all functions (anonymous or otherwise).--- Top-level functions have further restrictions that are checked--- during let-generalisation.-verifyFunctionParams :: Maybe Name -> [Pat] -> TermTypeM ()-verifyFunctionParams fname params =-  onFailure (CheckingParams fname) $-    verifyParams (foldMap patNames params) =<< mapM updateTypes params-  where-    verifyParams forbidden (p : ps)-      | d : _ <- S.toList $ patternDimNames p `S.intersection` forbidden =-        typeError p mempty $-          "Parameter" <+> pquote (ppr p)-            <+/> "refers to size" <+> pquote (pprName d)-            <> comma-            <+/> textwrap "which will not be accessible to the caller"-            <> comma-            <+/> textwrap "possibly because it is nested in a tuple or record."-            <+/> textwrap "Consider ascribing an explicit type that does not reference "-            <> pquote (pprName d)-            <> "."-      | otherwise = verifyParams forbidden' ps-      where-        forbidden' =-          case patternParam p of-            (Named v, _) -> forbidden `S.difference` S.singleton v-            _ -> forbidden-    verifyParams _ [] = return ()---- Returns the sizes of the immediate type produced,--- the sizes of parameter types, and the sizes of return types.-dimUses :: StructType -> (Names, Names, Names)-dimUses = (`execState` mempty) . traverseDims f-  where-    f _ PosImmediate (NamedDim v) =-      modify (<> (S.singleton (qualLeaf v), mempty, mempty))-    f _ PosParam (NamedDim v) =-      modify (<> (mempty, S.singleton (qualLeaf v), mempty))-    f _ PosReturn (NamedDim v) =-      modify (<> (mempty, mempty, S.singleton (qualLeaf v)))-    f _ _ _ = return ()---- | Find all type variables in the given type that are covered by the--- constraints, and produce type parameters that close over them.------ The passed-in list of type parameters is always prepended to the--- produced list of type parameters.-closeOverTypes ::-  Name ->-  SrcLoc ->-  [TypeParam] ->-  [StructType] ->-  StructType ->-  Constraints ->-  TermTypeM ([TypeParam], StructType, [VName])-closeOverTypes defname defloc tparams paramts ret substs = do-  (more_tparams, retext) <--    partitionEithers . catMaybes-      <$> mapM closeOver (M.toList $ M.map snd to_close_over)-  let retToAnyDim v = do-        guard $ v `S.member` ret_sizes-        UnknowableSize {} <- snd <$> M.lookup v substs-        Just $ SizeSubst $ AnyDim $ Just v-  return-    ( tparams ++ more_tparams,-      applySubst retToAnyDim ret,-      retext-    )-  where-    t = foldFunType paramts ret-    to_close_over = M.filterWithKey (\k _ -> k `S.member` visible) substs-    visible = typeVars t <> typeDimNames t--    (produced_sizes, param_sizes, ret_sizes) = dimUses t--    -- Avoid duplicate type parameters.-    closeOver (k, _)-      | k `elem` map typeParamName tparams =-        return Nothing-    closeOver (k, NoConstraint l usage) =-      return $ Just $ Left $ TypeParamType l k $ srclocOf usage-    closeOver (k, ParamType l loc) =-      return $ Just $ Left $ TypeParamType l k loc-    closeOver (k, Size Nothing usage) =-      return $ Just $ Left $ TypeParamDim k $ srclocOf usage-    closeOver (k, UnknowableSize _ _)-      | k `S.member` param_sizes = do-        notes <- dimNotes defloc $ NamedDim $ qualName k-        typeError defloc notes $-          "Unknowable size" <+> pquote (pprName k)-            <+> "imposes constraint on type of"-            <+> pquote (pprName defname)-            <> ", which is inferred as:"-            </> indent 2 (ppr t)-      | k `S.member` produced_sizes =-        return $ Just $ Right k-    closeOver (_, _) =-      return Nothing--letGeneralise ::-  Name ->-  SrcLoc ->-  [TypeParam] ->-  [Pat] ->-  StructType ->-  TermTypeM ([TypeParam], [Pat], StructType, [VName])-letGeneralise defname defloc tparams params rettype =-  onFailure (CheckingLetGeneralise defname) $ do-    now_substs <- getConstraints--    -- Candidates for let-generalisation are those type variables that-    ---    -- (1) were not known before we checked this function, and-    ---    -- (2) are not used in the (new) definition of any type variables-    -- known before we checked this function.-    ---    -- (3) are not referenced from an overloaded type (for example,-    -- are the element types of an incompletely resolved record type).-    -- This is a bit more restrictive than I'd like, and SML for-    -- example does not have this restriction.-    ---    -- Criteria (1) and (2) is implemented by looking at the binding-    -- level of the type variables.-    let keep_type_vars = overloadedTypeVars now_substs--    cur_lvl <- curLevel-    let candidate k (lvl, _) = (k `S.notMember` keep_type_vars) && lvl >= cur_lvl-        new_substs = M.filterWithKey candidate now_substs--    (tparams', rettype', retext) <--      closeOverTypes-        defname-        defloc-        tparams-        (map patternStructType params)-        rettype-        new_substs--    rettype'' <- updateTypes rettype'--    let used_sizes =-          foldMap typeDimNames $-            rettype'' : map patternStructType params-    case filter ((`S.notMember` used_sizes) . typeParamName) $-      filter isSizeParam tparams' of-      [] -> pure ()-      tp : _ -> unusedSize $ SizeBinder (typeParamName tp) (srclocOf tp)--    -- We keep those type variables that were not closed over by-    -- let-generalisation.-    modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` map typeParamName tparams'--    return (tparams', params, rettype'', retext)--checkFunBody ::-  [Pat] ->-  UncheckedExp ->-  Maybe StructType ->-  SrcLoc ->-  TermTypeM Exp-checkFunBody params body maybe_rettype loc = do-  body' <- noSizeEscape $ checkExp body--  -- Unify body return type with return annotation, if one exists.-  case maybe_rettype of-    Just rettype -> do-      (rettype_withdims, _) <- instantiateEmptyArrayDims loc "impl" Nonrigid rettype--      body_t <- expTypeFully body'-      -- We need to turn any sizes provided by "hidden" parameter-      -- names into existential sizes instead.-      let hidden = hiddenParamNames params-      (body_t', _) <--        unscopeType-          loc-          ( M.filterWithKey (const . (`S.member` hidden)) $-              foldMap patternMap params-          )-          body_t--      let usage = mkUsage (srclocOf body) "return type annotation"-      onFailure (CheckingReturn rettype (toStruct body_t')) $-        expect usage rettype_withdims $ toStruct body_t'--      -- We also have to make sure that uniqueness matches.  This is done-      -- explicitly, because uniqueness is ignored by unification.-      rettype' <- normTypeFully rettype-      body_t'' <- normTypeFully rettype -- Substs may have changed.-      unless (toStructural body_t'' `subtypeOf` toStructural rettype') $-        typeError (srclocOf body) mempty $-          "Body type" </> indent 2 (ppr body_t'')-            </> "is not a subtype of annotated type"-            </> indent 2 (ppr rettype')-    Nothing -> return ()--  return body'----- Consumption--occur :: Occurences -> TermTypeM ()-occur occs = modify $ \s -> s {stateOccs = stateOccs s <> occs}---- | Proclaim that we have made read-only use of the given variable.-observe :: Ident -> TermTypeM ()-observe (Ident nm (Info t) loc) =-  let als = AliasBound nm `S.insert` aliases t-   in occur [observation als loc]--describeVar :: SrcLoc -> VName -> TermTypeM Doc-describeVar loc v =-  gets $-    maybe ("variable" <+> pquote (pprName v)) (nameReason loc)-      . M.lookup v-      . stateNames--checkIfConsumable :: SrcLoc -> Aliasing -> TermTypeM ()-checkIfConsumable loc als = do-  vtable <- asks $ scopeVtable . termScope-  let consumable v = case M.lookup v vtable of-        Just (BoundV Local _ t)-          | arrayRank t > 0 -> unique t-          | Scalar TypeVar {} <- t -> unique t-          | Scalar Arrow {} <- t -> False-          | otherwise -> True-        Just (BoundV Global _ _) -> False-        _ -> True-  -- The sort ensures that AliasBound vars are shown before AliasFree.-  case map aliasVar $ sort $ filter (not . consumable . aliasVar) $ S.toList als of-    v : _ -> notConsumable loc =<< describeVar loc v-    [] -> return ()---- | Proclaim that we have written to the given variable.-consume :: SrcLoc -> Aliasing -> TermTypeM ()-consume loc als = do-  checkIfConsumable loc als-  occur [consumption als loc]---- | Proclaim that we have written to the given variable, and mark--- accesses to it and all of its aliases as invalid inside the given--- computation.-consuming :: Ident -> TermTypeM a -> TermTypeM a-consuming (Ident name (Info t) loc) m = do-  t' <- normTypeFully t-  consume loc $ AliasBound name `S.insert` aliases t'-  localScope consume' m-  where-    consume' scope =-      scope {scopeVtable = M.insert name (WasConsumed loc) $ scopeVtable scope}--collectOccurences :: TermTypeM a -> TermTypeM (a, Occurences)-collectOccurences m = do-  old <- gets stateOccs-  modify $ \s -> s {stateOccs = mempty}-  x <- m-  new <- gets stateOccs-  modify $ \s -> s {stateOccs = old}-  pure (x, new)--tapOccurences :: TermTypeM a -> TermTypeM (a, Occurences)-tapOccurences m = do-  (x, occs) <- collectOccurences m-  occur occs-  pure (x, occs)--removeSeminullOccurences :: TermTypeM a -> TermTypeM a-removeSeminullOccurences m = do-  (x, occs) <- collectOccurences m-  occur $ filter (not . seminullOccurence) occs-  pure x--checkIfUsed :: Occurences -> Ident -> TermTypeM ()-checkIfUsed occs v-  | not $ identName v `S.member` allOccuring occs,-    not $ "_" `isPrefixOf` prettyName (identName v) =-    warn (srclocOf v) $ "Unused variable" <+> pquote (pprName $ identName v) <+> "."-  | otherwise =-    return ()--alternative :: TermTypeM a -> TermTypeM b -> TermTypeM (a, b)-alternative m1 m2 = do-  (x, occurs1) <- collectOccurences $ noSizeEscape m1-  (y, occurs2) <- collectOccurences $ noSizeEscape m2-  checkOccurences occurs1-  checkOccurences occurs2-  occur $ occurs1 `altOccurences` occurs2-  pure (x, y)---- | Enter a context where nothing outside can be consumed (i.e. the--- body of a function definition).-noUnique :: TermTypeM a -> TermTypeM a-noUnique m = do-  (x, occs) <- collectOccurences $ localScope f m-  checkOccurences occs-  occur $ fst $ split occs-  pure x-  where-    f scope = scope {scopeVtable = M.map set $ scopeVtable scope}--    set (BoundV l tparams t) = BoundV l tparams $ t `setUniqueness` Nonunique-    set (OverloadedF ts pts rt) = OverloadedF ts pts rt-    set EqualityF = EqualityF-    set (WasConsumed loc) = WasConsumed loc--    split = unzip . map (\occ -> (occ {consumed = mempty}, occ {observed = mempty}))--onlySelfAliasing :: TermTypeM a -> TermTypeM a-onlySelfAliasing = localScope (\scope -> scope {scopeVtable = M.mapWithKey set $ scopeVtable scope})-  where-    set k (BoundV l tparams t) =-      BoundV l tparams $-        t `addAliases` S.intersection (S.singleton (AliasBound k))-    set _ (OverloadedF ts pts rt) = OverloadedF ts pts rt-    set _ EqualityF = EqualityF-    set _ (WasConsumed loc) = WasConsumed loc--arrayOfM ::-  (Pretty (ShapeDecl dim), Monoid as) =>-  SrcLoc ->-  TypeBase dim as ->-  ShapeDecl dim ->-  Uniqueness ->-  TermTypeM (TypeBase dim as)-arrayOfM loc t shape u = do-  arrayElemType (mkUsage loc "use as array element") "type used in array" t-  return $ arrayOf t shape u--updateTypes :: ASTMappable e => e -> TermTypeM e-updateTypes = astMap tv-  where-    tv =-      ASTMapper-        { mapOnExp = astMap tv,-          mapOnName = pure,-          mapOnQualName = pure,-          mapOnStructType = normTypeFully,-          mapOnPatType = normTypeFully-        }+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | Facilities for type-checking Futhark terms.  Checking a term+-- requires a little more context to track uniqueness and such.+--+-- Type inference is implemented through a variation of+-- Hindley-Milner.  The main complication is supporting the rich+-- number of built-in language constructs, as well as uniqueness+-- types.  This is mostly done in an ad hoc way, and many programs+-- will require the programmer to fall back on type annotations.+module Language.Futhark.TypeChecker.Terms+  ( checkOneExp,+    checkFunDef,+  )+where++import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Data.Either+import Data.List (find, foldl', partition)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.Set as S+import Futhark.IR.Primitive (intByteSize)+import Futhark.Util.Pretty hiding (bool, group, space)+import Language.Futhark+import Language.Futhark.Traversals+import Language.Futhark.TypeChecker.Match+import Language.Futhark.TypeChecker.Monad hiding (BoundV)+import Language.Futhark.TypeChecker.Terms.DoLoop+import Language.Futhark.TypeChecker.Terms.Monad+import Language.Futhark.TypeChecker.Terms.Pat+import Language.Futhark.TypeChecker.Types+import Language.Futhark.TypeChecker.Unify hiding (Usage)+import Prelude hiding (mod)++overloadedTypeVars :: Constraints -> Names+overloadedTypeVars = mconcat . map f . M.elems+  where+    f (_, HasFields fs _) = mconcat $ map typeVars $ M.elems fs+    f _ = mempty++--- Basic checking++-- | Determine if the two types are identical, ignoring uniqueness.+-- Mismatched dimensions are turned into fresh rigid type variables.+-- Causes a 'TypeError' if they fail to match, and otherwise returns+-- one of them.+unifyBranchTypes :: SrcLoc -> PatType -> PatType -> TermTypeM (PatType, [VName])+unifyBranchTypes loc t1 t2 =+  onFailure (CheckingBranches (toStruct t1) (toStruct t2)) $+    unifyMostCommon (mkUsage loc "unification of branch results") t1 t2++unifyBranches :: SrcLoc -> Exp -> Exp -> TermTypeM (PatType, [VName])+unifyBranches loc e1 e2 = do+  e1_t <- expTypeFully e1+  e2_t <- expTypeFully e2+  unifyBranchTypes loc e1_t e2_t++sliceShape ::+  Maybe (SrcLoc, Rigidity) ->+  Slice ->+  TypeBase (DimDecl VName) as ->+  TermTypeM (TypeBase (DimDecl VName) as, [VName])+sliceShape r slice t@(Array als u et (ShapeDecl orig_dims)) =+  runStateT (setDims <$> adjustDims slice orig_dims) []+  where+    setDims [] = stripArray (length orig_dims) t+    setDims dims' = Array als u et $ ShapeDecl dims'++    -- If the result is supposed to be a nonrigid size variable, then+    -- don't bother trying to create non-existential sizes.  This is+    -- necessary to make programs type-check without too much+    -- ceremony; see e.g. tests/inplace5.fut.+    isRigid Rigid {} = True+    isRigid _ = False+    refine_sizes = maybe False (isRigid . snd) r++    sliceSize orig_d i j stride =+      case r of+        Just (loc, Rigid _) -> do+          (d, ext) <-+            lift . extSize loc $+              SourceSlice orig_d' (bareExp <$> i) (bareExp <$> j) (bareExp <$> stride)+          modify (maybeToList ext ++)+          pure d+        Just (loc, Nonrigid) ->+          lift $ NamedDim . qualName <$> newDimVar loc Nonrigid "slice_dim"+        Nothing -> do+          v <- lift $ newID "slice_anydim"+          modify (v :)+          pure $ NamedDim $ qualName v+      where+        -- The original size does not matter if the slice is fully specified.+        orig_d'+          | isJust i, isJust j = Nothing+          | otherwise = Just orig_d++    adjustDims (DimFix {} : idxes') (_ : dims) =+      adjustDims idxes' dims+    -- Pat match some known slices to be non-existential.+    adjustDims (DimSlice i j stride : idxes') (_ : dims)+      | refine_sizes,+        maybe True ((== Just 0) . isInt64) i,+        Just j' <- maybeDimFromExp =<< j,+        maybe True ((== Just 1) . isInt64) stride =+        (j' :) <$> adjustDims idxes' dims+    adjustDims (DimSlice Nothing Nothing stride : idxes') (d : dims)+      | refine_sizes,+        maybe True (maybe False ((== 1) . abs) . isInt64) stride =+        (d :) <$> adjustDims idxes' dims+    adjustDims (DimSlice i j stride : idxes') (d : dims) =+      (:) <$> sliceSize d i j stride <*> adjustDims idxes' dims+    adjustDims _ dims =+      pure dims+sliceShape _ _ t = pure (t, [])++--- Main checkers++-- The closure of a lambda or local function are those variables that+-- it references, and which local to the current top-level function.+lexicalClosure :: [Pat] -> Occurrences -> TermTypeM Aliasing+lexicalClosure params closure = do+  vtable <- asks $ scopeVtable . termScope+  let isLocal v = case v `M.lookup` vtable of+        Just (BoundV Local _ _) -> True+        _ -> False+  pure . S.map AliasBound . S.filter isLocal $+    allOccurring closure S.\\ mconcat (map patNames params)++noAliasesIfOverloaded :: PatType -> TermTypeM PatType+noAliasesIfOverloaded t@(Scalar (TypeVar _ u tn [])) = do+  subst <- fmap snd . M.lookup (typeLeaf tn) <$> getConstraints+  case subst of+    Just Overloaded {} -> pure $ Scalar $ TypeVar mempty u tn []+    _ -> pure t+noAliasesIfOverloaded t =+  pure t++checkAscript ::+  SrcLoc ->+  UncheckedTypeDecl ->+  UncheckedExp ->+  TermTypeM (TypeDecl, Exp)+checkAscript loc (TypeDecl te NoInfo) e = do+  (te', decl_t, _) <- checkTypeExpNonrigid te+  e' <- checkExp e+  e_t <- toStruct <$> expTypeFully e'++  onFailure (CheckingAscription decl_t e_t) $+    unify (mkUsage loc "type ascription") decl_t e_t++  -- We also have to make sure that uniqueness matches.  This is done+  -- explicitly, because uniqueness is ignored by unification.+  e_t' <- normTypeFully e_t+  decl_t' <- normTypeFully decl_t+  unless (noSizes e_t' `subtypeOf` noSizes decl_t') $+    typeError loc mempty $+      "Type" <+> pquote (ppr e_t') <+> "is not a subtype of"+        <+> pquote (ppr decl_t') <> "."++  pure (TypeDecl te' $ Info decl_t', e')++checkCoerce ::+  SrcLoc ->+  UncheckedTypeDecl ->+  UncheckedExp ->+  TermTypeM (TypeDecl, Exp, [VName])+checkCoerce loc (TypeDecl te NoInfo) e = do+  (te', decl_t, ext) <- checkTypeExpRigid te RigidCoerce+  e' <- checkExp e+  e_t <- toStruct <$> expTypeFully e'++  (e_t_nonrigid, _) <-+    allDimsFreshInType loc Nonrigid "coerce_d" e_t++  onFailure (CheckingAscription decl_t e_t) $+    unify (mkUsage loc "type ascription") decl_t e_t_nonrigid++  -- We also have to make sure that uniqueness matches.  This is done+  -- explicitly, because uniqueness is ignored by unification.+  e_t' <- normTypeFully e_t+  decl_t' <- normTypeFully decl_t+  unless (noSizes e_t' `subtypeOf` noSizes decl_t') $+    typeError loc mempty $+      "Type" <+> pquote (ppr e_t') <+> "is not a subtype of"+        <+> pquote (ppr decl_t') <> "."++  pure (TypeDecl te' $ Info decl_t', e', ext)++unscopeType ::+  SrcLoc ->+  M.Map VName Ident ->+  PatType ->+  TermTypeM (PatType, [VName])+unscopeType tloc unscoped t = do+  (t', m) <- runStateT (traverseDims onDim t) mempty+  pure (t' `addAliases` S.map unAlias, M.elems m)+  where+    onDim bound _ (NamedDim d)+      | Just loc <- srclocOf <$> M.lookup (qualLeaf d) unscoped,+        not $ qualLeaf d `S.member` bound =+        inst loc $ qualLeaf d+    onDim _ _ d = pure d++    inst loc d = do+      prev <- gets $ M.lookup d+      case prev of+        Just d' -> pure $ NamedDim $ qualName d'+        Nothing -> do+          d' <- lift $ newDimVar tloc (Rigid $ RigidOutOfScope loc d) "d"+          modify $ M.insert d d'+          pure $ NamedDim $ qualName d'++    unAlias (AliasBound v) | v `M.member` unscoped = AliasFree v+    unAlias a = a++-- When a function result is not immediately bound to a name, we need+-- to invent a name for it so we can track it during aliasing+-- (uniqueness-error54.fut, uniqueness-error55.fut).+addResultAliases :: NameReason -> PatType -> TermTypeM PatType+addResultAliases r (Scalar (Record fs)) =+  Scalar . Record <$> traverse (addResultAliases r) fs+addResultAliases r (Scalar (Sum fs)) =+  Scalar . Sum <$> traverse (traverse (addResultAliases r)) fs+addResultAliases r (Scalar (TypeVar as u tn targs)) = do+  v <- newID "internal_app_result"+  modify $ \s -> s {stateNames = M.insert v r $ stateNames s}+  pure $ Scalar $ TypeVar (S.insert (AliasFree v) as) u tn targs+addResultAliases _ (Scalar t@Prim {}) = pure (Scalar t)+addResultAliases _ (Scalar t@Arrow {}) = pure (Scalar t)+addResultAliases r (Array als u t shape) = do+  v <- newID "internal_app_result"+  modify $ \s -> s {stateNames = M.insert v r $ stateNames s}+  pure $ Array (S.insert (AliasFree v) als) u t shape++-- 'checkApplyExp' is like 'checkExp', but tries to find the "root+-- function", for better error messages.+checkApplyExp :: UncheckedExp -> TermTypeM (Exp, ApplyOp)+checkApplyExp (AppExp (Apply e1 e2 _ loc) _) = do+  arg <- checkArg e2+  (e1', (fname, i)) <- checkApplyExp e1+  t <- expType e1'+  (t1, rt, argext, exts) <- checkApply loc (fname, i) t arg+  rt' <- addResultAliases (NameAppRes fname loc) rt+  return+    ( AppExp+        (Apply e1' (argExp arg) (Info (diet t1, argext)) loc)+        (Info $ AppRes rt' exts),+      (fname, i + 1)+    )+checkApplyExp e = do+  e' <- checkExp e+  return+    ( e',+      ( case e' of+          Var qn _ _ -> Just qn+          _ -> Nothing,+        0+      )+    )++checkExp :: UncheckedExp -> TermTypeM Exp+checkExp (Literal val loc) =+  pure $ Literal val loc+checkExp (StringLit vs loc) =+  pure $ StringLit vs loc+checkExp (IntLit val NoInfo loc) = do+  t <- newTypeVar loc "t"+  mustBeOneOf anyNumberType (mkUsage loc "integer literal") t+  pure $ IntLit val (Info $ fromStruct t) loc+checkExp (FloatLit val NoInfo loc) = do+  t <- newTypeVar loc "t"+  mustBeOneOf anyFloatType (mkUsage loc "float literal") t+  pure $ FloatLit val (Info $ fromStruct t) loc+checkExp (TupLit es loc) =+  TupLit <$> mapM checkExp es <*> pure loc+checkExp (RecordLit fs loc) = do+  fs' <- evalStateT (mapM checkField fs) mempty++  pure $ RecordLit fs' loc+  where+    checkField (RecordFieldExplicit f e rloc) = do+      errIfAlreadySet f rloc+      modify $ M.insert f rloc+      RecordFieldExplicit f <$> lift (checkExp e) <*> pure rloc+    checkField (RecordFieldImplicit name NoInfo rloc) = do+      errIfAlreadySet name rloc+      (QualName _ name', t) <- lift $ lookupVar rloc $ qualName name+      modify $ M.insert name rloc+      pure $ RecordFieldImplicit name' (Info t) rloc++    errIfAlreadySet f rloc = do+      maybe_sloc <- gets $ M.lookup f+      case maybe_sloc of+        Just sloc ->+          lift . typeError rloc mempty $+            "Field" <+> pquote (ppr f)+              <+> "previously defined at"+              <+> text (locStrRel rloc sloc) <> "."+        Nothing -> pure ()+checkExp (ArrayLit all_es _ loc) =+  -- Construct the result type and unify all elements with it.  We+  -- only create a type variable for empty arrays; otherwise we use+  -- the type of the first element.  This significantly cuts down on+  -- the number of type variables generated for pathologically large+  -- multidimensional array literals.+  case all_es of+    [] -> do+      et <- newTypeVar loc "t"+      t <- arrayOfM loc et (ShapeDecl [ConstDim 0]) Unique+      pure $ ArrayLit [] (Info t) loc+    e : es -> do+      e' <- checkExp e+      et <- expType e'+      es' <- mapM (unifies "type of first array element" (toStruct et) <=< checkExp) es+      et' <- normTypeFully et+      t <- arrayOfM loc et' (ShapeDecl [ConstDim $ length all_es]) Unique+      pure $ ArrayLit (e' : es') (Info t) loc+checkExp (AppExp (Range start maybe_step end loc) _) = do+  start' <- require "use in range expression" anySignedType =<< checkExp start+  start_t <- toStruct <$> expTypeFully start'+  maybe_step' <- case maybe_step of+    Nothing -> pure Nothing+    Just step -> do+      let warning = warn loc "First and second element of range are identical, this will produce an empty array."+      case (start, step) of+        (Literal x _, Literal y _) -> when (x == y) warning+        (Var x_name _ _, Var y_name _ _) -> when (x_name == y_name) warning+        _ -> pure ()+      Just <$> (unifies "use in range expression" start_t =<< checkExp step)++  let unifyRange e = unifies "use in range expression" start_t =<< checkExp e+  end' <- traverse unifyRange end++  end_t <- case end' of+    DownToExclusive e -> expType e+    ToInclusive e -> expType e+    UpToExclusive e -> expType e++  -- Special case some ranges to give them a known size.+  let dimFromBound = dimFromExp (SourceBound . bareExp)+  (dim, retext) <-+    case (isInt64 start', isInt64 <$> maybe_step', end') of+      (Just 0, Just (Just 1), UpToExclusive end'')+        | Scalar (Prim (Signed Int64)) <- end_t ->+          dimFromBound end''+      (Just 0, Nothing, UpToExclusive end'')+        | Scalar (Prim (Signed Int64)) <- end_t ->+          dimFromBound end''+      (Just 1, Just (Just 2), ToInclusive end'')+        | Scalar (Prim (Signed Int64)) <- end_t ->+          dimFromBound end''+      _ -> do+        d <- newDimVar loc (Rigid RigidRange) "range_dim"+        pure (NamedDim $ qualName d, Just d)++  t <- arrayOfM loc start_t (ShapeDecl [dim]) Unique+  let res = AppRes (t `setAliases` mempty) (maybeToList retext)++  pure $ AppExp (Range start' maybe_step' end' loc) (Info res)+checkExp (Ascript e decl loc) = do+  (decl', e') <- checkAscript loc decl e+  pure $ Ascript e' decl' loc+checkExp (AppExp (Coerce e decl loc) _) = do+  (decl', e', ext) <- checkCoerce loc decl e+  t <- expTypeFully e'+  t' <- matchDims (const . const pure) t $ fromStruct $ unInfo $ expandedType decl'+  pure $ AppExp (Coerce e' decl' loc) (Info $ AppRes t' ext)+checkExp (AppExp (BinOp (op, oploc) NoInfo (e1, _) (e2, _) loc) NoInfo) = do+  (op', ftype) <- lookupVar oploc op+  e1_arg <- checkArg e1+  e2_arg <- checkArg e2++  -- Note that the application to the first operand cannot fix any+  -- existential sizes, because it must by necessity be a function.+  (p1_t, rt, p1_ext, _) <- checkApply loc (Just op', 0) ftype e1_arg+  (p2_t, rt', p2_ext, retext) <- checkApply loc (Just op', 1) rt e2_arg++  pure $+    AppExp+      ( BinOp+          (op', oploc)+          (Info ftype)+          (argExp e1_arg, Info (toStruct p1_t, p1_ext))+          (argExp e2_arg, Info (toStruct p2_t, p2_ext))+          loc+      )+      (Info (AppRes rt' retext))+checkExp (Project k e NoInfo loc) = do+  e' <- checkExp e+  t <- expType e'+  kt <- mustHaveField (mkUsage loc $ "projection of field " ++ quote (pretty k)) k t+  pure $ Project k e' (Info kt) loc+checkExp (AppExp (If e1 e2 e3 loc) _) =+  sequentially checkCond $ \e1' _ -> do+    ((e2', e3'), dflow) <- tapOccurrences $ checkExp e2 `alternative` checkExp e3++    (brancht, retext) <- unifyBranches loc e2' e3'+    let t' = addAliases brancht $ S.filter $ (`S.notMember` allConsumed dflow) . aliasVar++    zeroOrderType+      (mkUsage loc "returning value of this type from 'if' expression")+      "type returned from branch"+      t'++    pure $ AppExp (If e1' e2' e3' loc) (Info $ AppRes t' retext)+  where+    checkCond = do+      e1' <- checkExp e1+      let bool = Scalar $ Prim Bool+      e1_t <- toStruct <$> expType e1'+      onFailure (CheckingRequired [bool] e1_t) $+        unify (mkUsage (srclocOf e1') "use as 'if' condition") bool e1_t+      pure e1'+checkExp (Parens e loc) =+  Parens <$> checkExp e <*> pure loc+checkExp (QualParens (modname, modnameloc) e loc) = do+  (modname', mod) <- lookupMod loc modname+  case mod of+    ModEnv env -> local (`withEnv` qualifyEnv modname' env) $ do+      e' <- checkExp e+      pure $ QualParens (modname', modnameloc) e' loc+    ModFun {} ->+      typeError loc mempty . withIndexLink "module-is-parametric" $+        "Module" <+> ppr modname <+> " is a parametric module."+  where+    qualifyEnv modname' env =+      env {envNameMap = M.map (qualify' modname') $ envNameMap env}+    qualify' modname' (QualName qs name) =+      QualName (qualQuals modname' ++ [qualLeaf modname'] ++ qs) name+checkExp (Var qn NoInfo loc) = do+  -- The qualifiers of a variable is divided into two parts: first a+  -- possibly-empty sequence of module qualifiers, followed by a+  -- possible-empty sequence of record field accesses.  We use scope+  -- information to perform the split, by taking qualifiers off the+  -- end until we find a module.++  (qn', t, fields) <- findRootVar (qualQuals qn) (qualLeaf qn)++  foldM checkField (Var qn' (Info t) loc) fields+  where+    findRootVar qs name =+      (whenFound <$> lookupVar loc (QualName qs name)) `catchError` notFound qs name++    whenFound (qn', t) = (qn', t, [])++    notFound qs name err+      | null qs = throwError err+      | otherwise = do+        (qn', t, fields) <-+          findRootVar (init qs) (last qs)+            `catchError` const (throwError err)+        pure (qn', t, fields ++ [name])++    checkField e k = do+      t <- expType e+      let usage = mkUsage loc $ "projection of field " ++ quote (pretty k)+      kt <- mustHaveField usage k t+      pure $ Project k e (Info kt) loc+checkExp (Negate arg loc) = do+  arg' <- require "numeric negation" anyNumberType =<< checkExp arg+  pure $ Negate arg' loc+checkExp (Not arg loc) = do+  arg' <- require "logical negation" (Bool : anyIntType) =<< checkExp arg+  pure $ Not arg' loc+checkExp e@(AppExp Apply {} _) = fst <$> checkApplyExp e+checkExp (AppExp (LetPat sizes pat e body loc) _) =+  sequentially (checkExp e) $ \e' e_occs -> do+    -- Not technically an ascription, but we want the pattern to have+    -- exactly the type of 'e'.+    t <- expType e'+    case anyConsumption e_occs of+      Just c ->+        let msg = "type computed with consumption at " ++ locStr (location c)+         in zeroOrderType (mkUsage loc "consumption in right-hand side of 'let'-binding") msg t+      _ -> pure ()++    incLevel . bindingSizes sizes $ \sizes' ->+      bindingPat sizes' pat (Ascribed t) $ \pat' -> do+        body' <- checkExp body+        (body_t, retext) <-+          unscopeType loc (sizesMap sizes' <> patternMap pat') =<< expTypeFully body'++        pure $ AppExp (LetPat sizes' pat' e' body' loc) (Info $ AppRes body_t retext)+  where+    sizesMap = foldMap onSize+    onSize size =+      M.singleton (sizeName size) $+        Ident (sizeName size) (Info (Scalar $ Prim $ Signed Int64)) (srclocOf size)+checkExp (AppExp (LetFun name (tparams, params, maybe_retdecl, NoInfo, e) body loc) _) =+  sequentially (checkBinding (name, maybe_retdecl, tparams, params, e, loc)) $+    \(tparams', params', maybe_retdecl', rettype, _, e') closure -> do+      closure' <- lexicalClosure params' closure++      bindSpaced [(Term, name)] $ do+        name' <- checkName Term name loc++        let arrow (xp, xt) yt = RetType [] $ Scalar $ Arrow () xp xt yt+            RetType _ ftype = foldr (arrow . patternParam) rettype params'+            entry = BoundV Local tparams' $ ftype `setAliases` closure'+            bindF scope =+              scope+                { scopeVtable =+                    M.insert name' entry $ scopeVtable scope,+                  scopeNameMap =+                    M.insert (Term, name) (qualName name') $+                      scopeNameMap scope+                }+        body' <- localScope bindF $ checkExp body++        -- We fake an ident here, but it's OK as it can't be a size+        -- anyway.+        let fake_ident = Ident name' (Info $ fromStruct ftype) mempty+        (body_t, ext) <-+          unscopeType loc (M.singleton name' fake_ident)+            =<< expTypeFully body'++        pure $+          AppExp+            ( LetFun+                name'+                (tparams', params', maybe_retdecl', Info rettype, e')+                body'+                loc+            )+            (Info $ AppRes body_t ext)+checkExp (AppExp (LetWith dest src slice ve body loc) _) =+  sequentially (checkIdent src) $ \src' _ -> do+    slice' <- checkSlice slice+    (t, _) <- newArrayType (srclocOf src) "src" $ sliceDims slice'+    unify (mkUsage loc "type of target array") t $ toStruct $ unInfo $ identType src'++    -- Need the fully normalised type here to get the proper aliasing information.+    src_t <- normTypeFully $ unInfo $ identType src'++    (elemt, _) <- sliceShape (Just (loc, Nonrigid)) slice' =<< normTypeFully t++    unless (unique src_t) $ notConsumable loc $ pquote $ pprName $ identName src++    sequentially (unifies "type of target array" (toStruct elemt) =<< checkExp ve) $ \ve' _ -> do+      ve_t <- expTypeFully ve'+      when (AliasBound (identName src') `S.member` aliases ve_t) $+        badLetWithValue src ve loc++      bindingIdent dest (src_t `setAliases` S.empty) $ \dest' -> do+        body' <- consuming src' $ checkExp body+        (body_t, ext) <-+          unscopeType loc (M.singleton (identName dest') dest')+            =<< expTypeFully body'+        pure $ AppExp (LetWith dest' src' slice' ve' body' loc) (Info $ AppRes body_t ext)+checkExp (Update src slice ve loc) = do+  slice' <- checkSlice slice+  (t, _) <- newArrayType (srclocOf src) "src" $ sliceDims slice'+  (elemt, _) <- sliceShape (Just (loc, Nonrigid)) slice' =<< normTypeFully t++  sequentially (checkExp ve >>= unifies "type of target array" elemt) $ \ve' _ ->+    sequentially (checkExp src >>= unifies "type of target array" t) $ \src' _ -> do+      src_t <- expTypeFully src'++      unless (unique src_t) $ notConsumable loc $ pquote $ ppr src++      let src_als = aliases src_t+      ve_t <- expTypeFully ve'+      unless (S.null $ src_als `S.intersection` aliases ve_t) $ badLetWithValue src ve loc++      consume loc src_als+      pure $ Update src' slice' ve' loc++-- Record updates are a bit hacky, because we do not have row typing+-- (yet?).  For now, we only permit record updates where we know the+-- full type up to the field we are updating.+checkExp (RecordUpdate src fields ve NoInfo loc) = do+  src' <- checkExp src+  ve' <- checkExp ve+  a <- expTypeFully src'+  foldM_ (flip $ mustHaveField usage) a fields+  ve_t <- expType ve'+  updated_t <- updateField fields ve_t =<< expTypeFully src'+  pure $ RecordUpdate src' fields ve' (Info updated_t) loc+  where+    usage = mkUsage loc "record update"+    updateField [] ve_t src_t = do+      (src_t', _) <- allDimsFreshInType loc Nonrigid "any" src_t+      onFailure (CheckingRecordUpdate fields (toStruct src_t') (toStruct ve_t)) $+        unify usage (toStruct src_t') (toStruct ve_t)+      -- Important that we return ve_t so that we get the right aliases.+      pure ve_t+    updateField (f : fs) ve_t (Scalar (Record m))+      | Just f_t <- M.lookup f m = do+        f_t' <- updateField fs ve_t f_t+        pure $ Scalar $ Record $ M.insert f f_t' m+    updateField _ _ _ =+      typeError loc mempty . withIndexLink "record-type-not-known" $+        "Full type of"+          </> indent 2 (ppr src)+          </> textwrap " is not known at this point.  Add a type annotation to the original record to disambiguate."++--+checkExp (AppExp (Index e slice loc) _) = do+  slice' <- checkSlice slice+  (t, _) <- newArrayType loc "e" $ sliceDims slice'+  e' <- unifies "being indexed at" t =<< checkExp e+  -- XXX, the RigidSlice here will be overridden in sliceShape with a proper value.+  (t', retext) <-+    sliceShape (Just (loc, Rigid (RigidSlice Nothing ""))) slice'+      =<< expTypeFully e'++  -- Remove aliases if the result is an overloaded type, because that+  -- will certainly not be aliased.+  t'' <- noAliasesIfOverloaded t'++  pure $ AppExp (Index e' slice' loc) (Info $ AppRes t'' retext)+checkExp (Assert e1 e2 NoInfo loc) = do+  e1' <- require "being asserted" [Bool] =<< checkExp e1+  e2' <- checkExp e2+  pure $ Assert e1' e2' (Info (pretty e1)) loc+checkExp (Lambda params body rettype_te NoInfo loc) =+  removeSeminullOccurrences . noUnique . incLevel . bindingParams [] params $ \_ params' -> do+    rettype_checked <- traverse checkTypeExpNonrigid rettype_te+    let declared_rettype =+          case rettype_checked of+            Just (_, st, _) -> Just st+            Nothing -> Nothing+    (body', closure) <-+      tapOccurrences $ checkFunBody params' body declared_rettype loc+    body_t <- expTypeFully body'++    params'' <- mapM updateTypes params'++    (rettype', rettype_st) <-+      case rettype_checked of+        Just (te, st, ext) ->+          pure (Just te, RetType ext st)+        Nothing -> do+          ret <-+            inferReturnSizes params'' . toStruct $+              inferReturnUniqueness params'' body_t+          pure (Nothing, ret)++    checkGlobalAliases params' body_t loc+    verifyFunctionParams Nothing params'++    closure' <- lexicalClosure params'' closure++    pure $ Lambda params'' body' rettype' (Info (closure', rettype_st)) loc+  where+    -- Inferring the sizes of the return type of a lambda is a lot+    -- like let-generalisation.  We wish to remove any rigid sizes+    -- that were created when checking the body, except for those that+    -- are visible in types that existed before we entered the body,+    -- are parameters, or are used in parameters.+    inferReturnSizes params' ret = do+      cur_lvl <- curLevel+      let named (Named x, _) = Just x+          named (Unnamed, _) = Nothing+          param_names = mapMaybe (named . patternParam) params'+          pos_sizes =+            typeDimNamesPos . foldFunType (map patternStructType params') $+              RetType [] ret+          hide k (lvl, _) =+            lvl >= cur_lvl && k `notElem` param_names && k `S.notMember` pos_sizes++      hidden_sizes <-+        S.fromList . M.keys . M.filterWithKey hide <$> getConstraints++      let onDim (NamedDim name)+            | qualLeaf name `S.member` hidden_sizes = S.singleton $ qualLeaf name+          onDim _ = mempty++      pure $ RetType (S.toList $ foldMap onDim $ nestedDims ret) ret+checkExp (OpSection op _ loc) = do+  (op', ftype) <- lookupVar loc op+  pure $ OpSection op' (Info ftype) loc+checkExp (OpSectionLeft op _ e _ _ loc) = do+  (op', ftype) <- lookupVar loc op+  e_arg <- checkArg e+  (t1, rt, argext, retext) <- checkApply loc (Just op', 0) ftype e_arg+  case (ftype, rt) of+    (Scalar (Arrow _ m1 _ _), Scalar (Arrow _ m2 t2 rettype)) ->+      pure $+        OpSectionLeft+          op'+          (Info ftype)+          (argExp e_arg)+          (Info (m1, toStruct t1, argext), Info (m2, toStruct t2))+          (Info rettype, Info retext)+          loc+    _ ->+      typeError loc mempty $+        "Operator section with invalid operator of type" <+> ppr ftype+checkExp (OpSectionRight op _ e _ NoInfo loc) = do+  (op', ftype) <- lookupVar loc op+  e_arg <- checkArg e+  case ftype of+    Scalar (Arrow as1 m1 t1 (RetType [] (Scalar (Arrow as2 m2 t2 (RetType dims2 ret))))) -> do+      (t2', ret', argext, _) <-+        checkApply+          loc+          (Just op', 1)+          (Scalar $ Arrow as2 m2 t2 $ RetType [] $ Scalar $ Arrow as1 m1 t1 $ RetType [] ret)+          e_arg+      pure $+        OpSectionRight+          op'+          (Info ftype)+          (argExp e_arg)+          (Info (m1, toStruct t1), Info (m2, toStruct t2', argext))+          (Info $ RetType dims2 $ addAliases ret (<> aliases ret'))+          loc+    _ ->+      typeError loc mempty $+        "Operator section with invalid operator of type" <+> ppr ftype+checkExp (ProjectSection fields NoInfo loc) = do+  a <- newTypeVar loc "a"+  let usage = mkUsage loc "projection at"+  b <- foldM (flip $ mustHaveField usage) a fields+  pure $ ProjectSection fields (Info $ Scalar $ Arrow mempty Unnamed a $ RetType [] b) loc+checkExp (IndexSection slice NoInfo loc) = do+  slice' <- checkSlice slice+  (t, _) <- newArrayType loc "e" $ sliceDims slice'+  (t', retext) <- sliceShape Nothing slice' t+  pure $ IndexSection slice' (Info $ fromStruct $ Scalar $ Arrow mempty Unnamed t $ RetType retext t') loc+checkExp (AppExp (DoLoop _ mergepat mergeexp form loopbody loc) _) = do+  ((sparams, mergepat', mergeexp', form', loopbody'), appres) <-+    checkDoLoop checkExp (mergepat, mergeexp, form, loopbody) loc+  pure $+    AppExp+      (DoLoop sparams mergepat' mergeexp' form' loopbody' loc)+      (Info appres)+checkExp (Constr name es NoInfo loc) = do+  t <- newTypeVar loc "t"+  es' <- mapM checkExp es+  ets <- mapM expTypeFully es'+  mustHaveConstr (mkUsage loc "use of constructor") name t (toStruct <$> ets)+  -- A sum value aliases *anything* that went into its construction.+  let als = foldMap aliases ets+  pure $ Constr name es' (Info $ fromStruct t `addAliases` (<> als)) loc+checkExp (AppExp (Match e cs loc) _) =+  sequentially (checkExp e) $ \e' _ -> do+    mt <- expTypeFully e'+    (cs', t, retext) <- checkCases mt cs+    zeroOrderType+      (mkUsage loc "being returned 'match'")+      "type returned from pattern match"+      t+    pure $ AppExp (Match e' cs' loc) (Info $ AppRes t retext)+checkExp (Attr info e loc) =+  Attr <$> checkAttr info <*> checkExp e <*> pure loc++checkCases ::+  PatType ->+  NE.NonEmpty (CaseBase NoInfo Name) ->+  TermTypeM (NE.NonEmpty (CaseBase Info VName), PatType, [VName])+checkCases mt rest_cs =+  case NE.uncons rest_cs of+    (c, Nothing) -> do+      (c', t, retext) <- checkCase mt c+      pure (c' NE.:| [], t, retext)+    (c, Just cs) -> do+      (((c', c_t, _), (cs', cs_t, _)), dflow) <-+        tapOccurrences $ checkCase mt c `alternative` checkCases mt cs+      (brancht, retext) <- unifyBranchTypes (srclocOf c) c_t cs_t+      let t =+            addAliases+              brancht+              (`S.difference` S.map AliasBound (allConsumed dflow))+      pure (NE.cons c' cs', t, retext)++checkCase ::+  PatType ->+  CaseBase NoInfo Name ->+  TermTypeM (CaseBase Info VName, PatType, [VName])+checkCase mt (CasePat p e loc) =+  bindingPat [] p (Ascribed mt) $ \p' -> do+    e' <- checkExp e+    (t, retext) <- unscopeType loc (patternMap p') =<< expTypeFully e'+    pure (CasePat p' e' loc, t, retext)++-- | An unmatched pattern. Used in in the generation of+-- unmatched pattern warnings by the type checker.+data Unmatched p+  = UnmatchedNum p [PatLit]+  | UnmatchedBool p+  | UnmatchedConstr p+  | Unmatched p+  deriving (Functor, Show)++instance Pretty (Unmatched (PatBase Info VName)) where+  ppr um = case um of+    (UnmatchedNum p nums) -> ppr' p <+> "where p is not one of" <+> ppr nums+    (UnmatchedBool p) -> ppr' p+    (UnmatchedConstr p) -> ppr' p+    (Unmatched p) -> ppr' p+    where+      ppr' (PatAscription p t _) = ppr p <> ":" <+> ppr t+      ppr' (PatParens p _) = parens $ ppr' p+      ppr' (PatAttr _ p _) = parens $ ppr' p+      ppr' (Id v _ _) = pprName v+      ppr' (TuplePat pats _) = parens $ commasep $ map ppr' pats+      ppr' (RecordPat fs _) = braces $ commasep $ map ppField fs+        where+          ppField (name, t) = text (nameToString name) <> equals <> ppr' t+      ppr' Wildcard {} = "_"+      ppr' (PatLit e _ _) = ppr e+      ppr' (PatConstr n _ ps _) = "#" <> ppr n <+> sep (map ppr' ps)++checkUnmatched :: Exp -> TermTypeM ()+checkUnmatched e = void $ checkUnmatched' e >> astMap tv e+  where+    checkUnmatched' (AppExp (Match _ cs loc) _) =+      let ps = fmap (\(CasePat p _ _) -> p) cs+       in case unmatched $ NE.toList ps of+            [] -> pure ()+            ps' ->+              typeError loc mempty . withIndexLink "unmatched-cases" $+                "Unmatched cases in match expression:"+                  </> indent 2 (stack (map ppr ps'))+    checkUnmatched' _ = pure ()+    tv = identityMapper {mapOnExp = \e' -> checkUnmatched' e' >> pure e'}++checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident+checkIdent (Ident name _ loc) = do+  (QualName _ name', vt) <- lookupVar loc (qualName name)+  pure $ Ident name' (Info vt) loc++checkSlice :: UncheckedSlice -> TermTypeM Slice+checkSlice = mapM checkDimIndex+  where+    checkDimIndex (DimFix i) =+      DimFix <$> (require "use as index" anySignedType =<< checkExp i)+    checkDimIndex (DimSlice i j s) =+      DimSlice <$> check i <*> check j <*> check s++    check =+      maybe (return Nothing) $+        fmap Just . unifies "use as index" (Scalar $ Prim $ Signed Int64) <=< checkExp++-- The number of dimensions affected by this slice (so the minimum+-- rank of the array we are slicing).+sliceDims :: Slice -> Int+sliceDims = length++type Arg = (Exp, PatType, Occurrences, SrcLoc)++argExp :: Arg -> Exp+argExp (e, _, _, _) = e++argType :: Arg -> PatType+argType (_, t, _, _) = t++checkArg :: UncheckedExp -> TermTypeM Arg+checkArg arg = do+  (arg', dflow) <- collectOccurrences $ checkExp arg+  arg_t <- expType arg'+  pure (arg', arg_t, dflow, srclocOf arg')++instantiateDimsInReturnType ::+  SrcLoc ->+  Maybe (QualName VName) ->+  RetTypeBase (DimDecl VName) als ->+  TermTypeM (TypeBase (DimDecl VName) als, [VName])+instantiateDimsInReturnType tloc fname =+  instantiateEmptyArrayDims tloc $ Rigid $ RigidRet fname++-- Some information about the function/operator we are trying to+-- apply, and how many arguments it has previously accepted.  Used for+-- generating nicer type errors.+type ApplyOp = (Maybe (QualName VName), Int)++-- | Extract all those names that are bound inside the type.+boundInsideType :: TypeBase (DimDecl VName) as -> S.Set VName+boundInsideType (Array _ _ t _) = boundInsideType (Scalar t)+boundInsideType (Scalar Prim {}) = mempty+boundInsideType (Scalar (TypeVar _ _ _ targs)) = foldMap f targs+  where+    f (TypeArgType t _) = boundInsideType t+    f TypeArgDim {} = mempty+boundInsideType (Scalar (Record fs)) = foldMap boundInsideType fs+boundInsideType (Scalar (Sum cs)) = foldMap (foldMap boundInsideType) cs+boundInsideType (Scalar (Arrow _ pn t1 (RetType dims t2))) =+  pn' <> boundInsideType t1 <> S.fromList dims <> boundInsideType t2+  where+    pn' = case pn of+      Unnamed -> mempty+      Named v -> S.singleton v++-- Returns the sizes of the immediate type produced,+-- the sizes of parameter types, and the sizes of return types.+dimUses :: StructType -> (Names, Names)+dimUses = flip execState mempty . traverseDims f+  where+    f bound _ (NamedDim v) | qualLeaf v `S.member` bound = pure ()+    f _ PosImmediate (NamedDim v) = modify ((S.singleton (qualLeaf v), mempty) <>)+    f _ PosParam (NamedDim v) = modify ((mempty, S.singleton (qualLeaf v)) <>)+    f _ _ _ = pure ()++checkApply ::+  SrcLoc ->+  ApplyOp ->+  PatType ->+  Arg ->+  TermTypeM (PatType, PatType, Maybe VName, [VName])+checkApply+  loc+  (fname, _)+  (Scalar (Arrow as pname tp1 tp2))+  (argexp, argtype, dflow, argloc) =+    onFailure (CheckingApply fname argexp (toStruct tp1) (toStruct argtype)) $ do+      expect (mkUsage argloc "use as function argument") (toStruct tp1) (toStruct argtype)++      -- Perform substitutions of instantiated variables in the types.+      tp1' <- normTypeFully tp1+      (tp2', ext) <- instantiateDimsInReturnType loc fname =<< normTypeFully tp2+      argtype' <- normTypeFully argtype++      -- Check whether this would produce an impossible return type.+      let (tp2_produced_dims, tp2_paramdims) = dimUses $ toStruct tp2'+          problematic = S.fromList ext <> boundInsideType argtype'+      when (any (`S.member` problematic) (tp2_paramdims `S.difference` tp2_produced_dims)) $ do+        typeError loc mempty . withIndexLink "existential-param-ret" $+          "Existential size would appear in function parameter of return type:"+            </> indent 2 (ppr (RetType ext tp2'))+            </> textwrap "This is usually because a higher-order function is used with functional arguments that return existential sizes or locally named sizes, which are then used as parameters of other function arguments."++      occur [observation as loc]++      checkOccurrences dflow++      case anyConsumption dflow of+        Just c ->+          let msg = "type of expression with consumption at " ++ locStr (location c)+           in zeroOrderType (mkUsage argloc "potential consumption in expression") msg tp1+        _ -> pure ()++      occurs <- (dflow `seqOccurrences`) <$> consumeArg argloc argtype' (diet tp1')++      checkIfConsumable loc $ S.map AliasBound $ allConsumed occurs+      occur occurs++      (argext, parsubst) <-+        case pname of+          Named pname'+            | (Scalar (Prim (Signed Int64))) <- tp1' -> do+              (d, argext) <- dimFromArg fname argexp+              pure+                ( argext,+                  (`M.lookup` M.singleton pname' (SizeSubst d))+                )+          _ -> pure (Nothing, const Nothing)+      let tp2'' = applySubst parsubst $ returnType tp2' (diet tp1') argtype'++      pure (tp1', tp2'', argext, ext)+checkApply loc fname tfun@(Scalar TypeVar {}) arg = do+  tv <- newTypeVar loc "b"+  -- Change the uniqueness of the argument type because we never want+  -- to infer that a function is consuming.+  let argt_nonunique = toStruct (argType arg) `setUniqueness` Nonunique+  unify (mkUsage loc "use as function") (toStruct tfun) $+    Scalar $ Arrow mempty Unnamed argt_nonunique $ RetType [] tv+  tfun' <- normPatType tfun+  checkApply loc fname tfun' arg+checkApply loc (fname, prev_applied) ftype (argexp, _, _, _) = do+  let fname' = maybe "expression" (pquote . ppr) fname++  typeError loc mempty $+    if prev_applied == 0+      then+        "Cannot apply" <+> fname' <+> "as function, as it has type:"+          </> indent 2 (ppr ftype)+      else+        "Cannot apply" <+> fname' <+> "to argument #" <> ppr (prev_applied + 1)+          <+> pquote (shorten $ pretty $ flatten $ ppr argexp) <> ","+          <+/> "as"+          <+> fname'+          <+> "only takes"+          <+> ppr prev_applied+          <+> arguments <> "."+  where+    arguments+      | prev_applied == 1 = "argument"+      | otherwise = "arguments"++-- | @returnType ret_type arg_diet arg_type@ gives result of applying+-- an argument the given types to a function with the given return+-- type, consuming the argument with the given diet.+returnType ::+  PatType ->+  Diet ->+  PatType ->+  PatType+returnType (Array _ Unique et shape) _ _ =+  Array mempty Unique et shape+returnType (Array als Nonunique et shape) d arg =+  Array (als <> arg_als) Unique et shape -- Intentional!+  where+    arg_als = aliases $ maskAliases arg d+returnType (Scalar (Record fs)) d arg =+  Scalar $ Record $ fmap (\et -> returnType et d arg) fs+returnType (Scalar (Prim t)) _ _ =+  Scalar $ Prim t+returnType (Scalar (TypeVar _ Unique t targs)) _ _ =+  Scalar $ TypeVar mempty Unique t targs+returnType (Scalar (TypeVar als Nonunique t targs)) d arg =+  Scalar $ TypeVar (als <> arg_als) Unique t targs -- Intentional!+  where+    arg_als = aliases $ maskAliases arg d+returnType (Scalar (Arrow old_als v t1 (RetType dims t2))) d arg =+  Scalar $ Arrow als v (t1 `setAliases` mempty) $ RetType dims $ t2 `setAliases` als+  where+    -- Make sure to propagate the aliases of an existing closure.+    als = old_als <> aliases (maskAliases arg d)+returnType (Scalar (Sum cs)) d arg =+  Scalar $ Sum $ (fmap . fmap) (\et -> returnType et d arg) cs++-- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from+-- the parts of @t@ that are denoted as consumed by the 'Diet' @d@.+maskAliases ::+  Monoid as =>+  TypeBase shape as ->+  Diet ->+  TypeBase shape as+maskAliases t Consume = t `setAliases` mempty+maskAliases t Observe = t+maskAliases (Scalar (Record ets)) (RecordDiet ds) =+  Scalar $ Record $ M.intersectionWith maskAliases ets ds+maskAliases t FuncDiet {} = t+maskAliases _ _ = error "Invalid arguments passed to maskAliases."++consumeArg :: SrcLoc -> PatType -> Diet -> TermTypeM [Occurrence]+consumeArg loc (Scalar (Record ets)) (RecordDiet ds) =+  concat . M.elems <$> traverse (uncurry $ consumeArg loc) (M.intersectionWith (,) ets ds)+consumeArg loc (Array _ Nonunique _ _) Consume =+  typeError loc mempty . withIndexLink "consuming-parameter" $+    "Consuming parameter passed non-unique argument."+consumeArg loc (Scalar (TypeVar _ Nonunique _ _)) Consume =+  typeError loc mempty . withIndexLink "consuming-parameter" $+    "Consuming parameter passed non-unique argument."+consumeArg loc (Scalar (Arrow _ _ t1 _)) (FuncDiet d _)+  | not $ contravariantArg t1 d =+    typeError loc mempty . withIndexLink "consuming-argument" $+      "Non-consuming higher-order parameter passed consuming argument."+  where+    contravariantArg (Array _ Unique _ _) Observe =+      False+    contravariantArg (Scalar (TypeVar _ Unique _ _)) Observe =+      False+    contravariantArg (Scalar (Record ets)) (RecordDiet ds) =+      and (M.intersectionWith contravariantArg ets ds)+    contravariantArg (Scalar (Arrow _ _ tp (RetType _ tr))) (FuncDiet dp dr) =+      contravariantArg tp dp && contravariantArg tr dr+    contravariantArg _ _ =+      True+consumeArg loc at Consume = pure [consumption (aliases at) loc]+consumeArg loc at _ = pure [observation (aliases at) loc]++-- | Type-check a single expression in isolation.  This expression may+-- turn out to be polymorphic, in which case the list of type+-- parameters will be non-empty.+checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp)+checkOneExp e = fmap fst . runTermTypeM $ do+  e' <- checkExp e+  let t = toStruct $ typeOf e'+  (tparams, _, _, _) <-+    letGeneralise (nameFromString "<exp>") (srclocOf e) [] [] t+  fixOverloadedTypes $ typeVars t+  e'' <- updateTypes e'+  checkUnmatched e''+  causalityCheck e''+  literalOverflowCheck e''+  pure (tparams, e'')++-- Verify that all sum type constructors and empty array literals have+-- a size that is known (rigid or a type parameter).  This is to+-- ensure that we can actually determine their shape at run-time.+causalityCheck :: Exp -> TermTypeM ()+causalityCheck binding_body = do+  constraints <- getConstraints++  let checkCausality what known t loc+        | (d, dloc) : _ <-+            mapMaybe (unknown constraints known) $+              S.toList $ typeDimNames $ toStruct t =+          Just $ lift $ causality what loc d dloc t+        | otherwise = Nothing++      checkParamCausality known p =+        checkCausality (ppr p) known (patternType p) (srclocOf p)++      onExp ::+        S.Set VName ->+        Exp ->+        StateT (S.Set VName) (Either TypeError) Exp++      onExp known (Var v (Info t) loc)+        | Just bad <- checkCausality (pquote (ppr v)) known t loc =+          bad+      onExp known (ProjectSection _ (Info t) loc)+        | Just bad <- checkCausality "projection section" known t loc =+          bad+      onExp known (IndexSection _ (Info t) loc)+        | Just bad <- checkCausality "projection section" known t loc =+          bad+      onExp known (OpSectionRight _ (Info t) _ _ _ loc)+        | Just bad <- checkCausality "operator section" known t loc =+          bad+      onExp known (OpSectionLeft _ (Info t) _ _ _ loc)+        | Just bad <- checkCausality "operator section" known t loc =+          bad+      onExp known (ArrayLit [] (Info t) loc)+        | Just bad <- checkCausality "empty array" known t loc =+          bad+      onExp known (Lambda params _ _ _ _)+        | bad : _ <- mapMaybe (checkParamCausality known) params =+          bad+      onExp known e@(AppExp (LetPat _ _ bindee_e body_e _) (Info res)) = do+        sequencePoint known bindee_e body_e $ appResExt res+        pure e+      onExp known e@(AppExp (Apply f arg (Info (_, p)) _) (Info res)) = do+        sequencePoint known arg f $ maybeToList p ++ appResExt res+        pure e+      onExp+        known+        e@(AppExp (BinOp (f, floc) ft (x, Info (_, xp)) (y, Info (_, yp)) _) (Info res)) = do+          args_known <-+            lift $+              execStateT (sequencePoint known x y $ catMaybes [xp, yp]) mempty+          void $ onExp (args_known <> known) (Var f ft floc)+          modify ((args_known <> S.fromList (appResExt res)) <>)+          pure e+      onExp known e@(AppExp e' (Info res)) = do+        recurse known e'+        modify (<> S.fromList (appResExt res))+        pure e+      onExp known e = do+        recurse known e+        pure e++      recurse known = void . astMap mapper+        where+          mapper = identityMapper {mapOnExp = onExp known}++      sequencePoint known x y ext = do+        new_known <- lift $ execStateT (onExp known x) mempty+        void $ onExp (new_known <> known) y+        modify ((new_known <> S.fromList ext) <>)++  either throwError (const $ pure ()) $+    evalStateT (onExp mempty binding_body) mempty+  where+    unknown constraints known v = do+      guard $ v `S.notMember` known+      loc <- unknowable constraints v+      pure (v, loc)++    unknowable constraints v =+      case snd <$> M.lookup v constraints of+        Just (UnknowableSize loc _) -> Just loc+        _ -> Nothing++    causality what loc d dloc t =+      Left . TypeError loc mempty . withIndexLink "causality-check" $+        "Causality check: size" <+/> pquote (pprName d)+          <+/> "needed for type of"+          <+> what <> colon+          </> indent 2 (ppr t)+          </> "But"+          <+> pquote (pprName d)+          <+> "is computed at"+          <+/> text (locStrRel loc dloc) <> "."+          </> ""+          </> "Hint:"+          <+> align+            ( textwrap "Bind the expression producing" <+> pquote (pprName d)+                <+> "with 'let' beforehand."+            )++-- | Traverse the expression, emitting warnings if any of the literals overflow+-- their inferred types+--+-- Note: currently unable to detect float underflow (such as 1e-400 -> 0)+literalOverflowCheck :: Exp -> TermTypeM ()+literalOverflowCheck = void . check+  where+    check e@(IntLit x ty loc) =+      e <$ case ty of+        Info (Scalar (Prim t)) -> warnBounds (inBoundsI x t) x t loc+        _ -> error "Inferred type of int literal is not a number"+    check e@(FloatLit x ty loc) =+      e <$ case ty of+        Info (Scalar (Prim (FloatType t))) -> warnBounds (inBoundsF x t) x t loc+        _ -> error "Inferred type of float literal is not a float"+    check e@(Negate (IntLit x ty loc1) loc2) =+      e <$ case ty of+        Info (Scalar (Prim t)) -> warnBounds (inBoundsI (- x) t) (- x) t (loc1 <> loc2)+        _ -> error "Inferred type of int literal is not a number"+    check e = astMap identityMapper {mapOnExp = check} e+    bitWidth ty = 8 * intByteSize ty :: Int+    inBoundsI x (Signed t) = x >= -2 ^ (bitWidth t - 1) && x < 2 ^ (bitWidth t - 1)+    inBoundsI x (Unsigned t) = x >= 0 && x < 2 ^ bitWidth t+    inBoundsI x (FloatType Float16) = not $ isInfinite (fromIntegral x :: Half)+    inBoundsI x (FloatType Float32) = not $ isInfinite (fromIntegral x :: Float)+    inBoundsI x (FloatType Float64) = not $ isInfinite (fromIntegral x :: Double)+    inBoundsI _ Bool = error "Inferred type of int literal is not a number"+    inBoundsF x Float16 = not $ isInfinite (realToFrac x :: Float)+    inBoundsF x Float32 = not $ isInfinite (realToFrac x :: Float)+    inBoundsF x Float64 = not $ isInfinite x+    warnBounds inBounds x ty loc =+      unless inBounds $+        typeError loc mempty . withIndexLink "literal-out-of-bounds" $+          "Literal " <> ppr x+            <> " out of bounds for inferred type "+            <> ppr ty+            <> "."++-- | Type-check a top-level (or module-level) function definition.+-- Despite the name, this is also used for checking constant+-- definitions, by treating them as 0-ary functions.+checkFunDef ::+  ( Name,+    Maybe UncheckedTypeExp,+    [UncheckedTypeParam],+    [UncheckedPat],+    UncheckedExp,+    SrcLoc+  ) ->+  TypeM+    ( VName,+      [TypeParam],+      [Pat],+      Maybe (TypeExp VName),+      StructRetType,+      [VName],+      Exp+    )+checkFunDef (fname, maybe_retdecl, tparams, params, body, loc) =+  fmap fst . runTermTypeM $ do+    (tparams', params', maybe_retdecl', RetType dims rettype', retext, body') <-+      checkBinding (fname, maybe_retdecl, tparams, params, body, loc)++    -- Since this is a top-level function, we also resolve overloaded+    -- types, using either defaults or complaining about ambiguities.+    fixOverloadedTypes $+      typeVars rettype' <> foldMap (typeVars . patternType) params'++    -- Then replace all inferred types in the body and parameters.+    body'' <- updateTypes body'+    params'' <- updateTypes params'+    maybe_retdecl'' <- traverse updateTypes maybe_retdecl'+    rettype'' <- normTypeFully rettype'++    -- Check if pattern matches are exhaustive and yield+    -- errors if not.+    checkUnmatched body''++    -- Check if the function body can actually be evaluated.+    causalityCheck body''++    literalOverflowCheck body''++    bindSpaced [(Term, fname)] $ do+      fname' <- checkName Term fname loc+      when (nameToString fname `elem` doNotShadow) $+        typeError loc mempty . withIndexLink "may-not-be-redefined" $+          "The" <+> pprName fname <+> "operator may not be redefined."++      pure (fname', tparams', params'', maybe_retdecl'', RetType dims rettype'', retext, body'')++-- | This is "fixing" as in "setting them", not "correcting them".  We+-- only make very conservative fixing.+fixOverloadedTypes :: Names -> TermTypeM ()+fixOverloadedTypes tyvars_at_toplevel =+  getConstraints >>= mapM_ fixOverloaded . M.toList . M.map snd+  where+    fixOverloaded (v, Overloaded ots usage)+      | Signed Int32 `elem` ots = do+        unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $+          Scalar $ Prim $ Signed Int32+        when (v `S.member` tyvars_at_toplevel) $+          warn usage "Defaulting ambiguous type to i32."+      | FloatType Float64 `elem` ots = do+        unify usage (Scalar (TypeVar () Nonunique (typeName v) [])) $+          Scalar $ Prim $ FloatType Float64+        when (v `S.member` tyvars_at_toplevel) $+          warn usage "Defaulting ambiguous type to f64."+      | otherwise =+        typeError usage mempty . withIndexLink "ambiguous-type" $+          "Type is ambiguous (could be one of" <+> commasep (map ppr ots) <> ")."+            </> "Add a type annotation to disambiguate the type."+    fixOverloaded (_, NoConstraint _ usage) =+      typeError usage mempty . withIndexLink "ambiguous-type" $+        "Type of expression is ambiguous."+          </> "Add a type annotation to disambiguate the type."+    fixOverloaded (_, Equality usage) =+      typeError usage mempty . withIndexLink "ambiguous-type" $+        "Type is ambiguous (must be equality type)."+          </> "Add a type annotation to disambiguate the type."+    fixOverloaded (_, HasFields fs usage) =+      typeError usage mempty . withIndexLink "ambiguous-type" $+        "Type is ambiguous.  Must be record with fields:"+          </> indent 2 (stack $ map field $ M.toList fs)+          </> "Add a type annotation to disambiguate the type."+      where+        field (l, t) = ppr l <> colon <+> align (ppr t)+    fixOverloaded (_, HasConstrs cs usage) =+      typeError usage mempty . withIndexLink "ambiguous-type" $+        "Type is ambiguous (must be a sum type with constructors:"+          <+> ppr (Sum cs) <> ")."+          </> "Add a type annotation to disambiguate the type."+    fixOverloaded (v, Size Nothing usage) =+      typeError usage mempty $ "Size" <+> pquote (pprName v) <+> "is ambiguous.\n"+    fixOverloaded _ = pure ()++hiddenParamNames :: [Pat] -> Names+hiddenParamNames params = hidden+  where+    param_all_names = mconcat $ map patNames params+    named (Named x, _) = Just x+    named (Unnamed, _) = Nothing+    param_names =+      S.fromList $ mapMaybe (named . patternParam) params+    hidden = param_all_names `S.difference` param_names++inferredReturnType :: SrcLoc -> [Pat] -> PatType -> TermTypeM StructType+inferredReturnType loc params t =+  -- The inferred type may refer to names that are bound by the+  -- parameter patterns, but which will not be visible in the type.+  -- These we must turn into fresh type variables, which will be+  -- existential in the return type.+  fmap (toStruct . fst) $+    unscopeType+      loc+      (M.filterWithKey (const . (`S.member` hidden)) $ foldMap patternMap params)+      $ inferReturnUniqueness params t+  where+    hidden = hiddenParamNames params++checkBinding ::+  ( Name,+    Maybe UncheckedTypeExp,+    [UncheckedTypeParam],+    [UncheckedPat],+    UncheckedExp,+    SrcLoc+  ) ->+  TermTypeM+    ( [TypeParam],+      [Pat],+      Maybe (TypeExp VName),+      StructRetType,+      [VName],+      Exp+    )+checkBinding (fname, maybe_retdecl, tparams, params, body, loc) =+  noUnique . incLevel . bindingParams tparams params $ \tparams' params' -> do+    maybe_retdecl' <- forM maybe_retdecl $ \retdecl ->+      checkTypeExpNonrigid retdecl++    body' <-+      checkFunBody+        params'+        body+        ((\(_, x, _) -> x) <$> maybe_retdecl')+        (maybe loc srclocOf maybe_retdecl)++    params'' <- mapM updateTypes params'+    body_t <- expTypeFully body'++    (maybe_retdecl'', rettype) <- case maybe_retdecl' of+      Just (retdecl', ret, _) -> do+        let rettype_structural = toStructural ret+        checkReturnAlias rettype_structural params'' body_t++        when (null params) $ nothingMustBeUnique loc rettype_structural++        ret' <- normTypeFully ret++        pure (Just retdecl', ret')+      Nothing+        | null params ->+          pure (Nothing, toStruct $ body_t `setUniqueness` Nonunique)+        | otherwise -> do+          body_t' <- inferredReturnType loc params'' body_t+          pure (Nothing, body_t')++    verifyFunctionParams (Just fname) params''++    (tparams'', params''', rettype'', retext) <-+      letGeneralise fname loc tparams' params'' rettype++    checkGlobalAliases params'' body_t loc++    pure (tparams'', params''', maybe_retdecl'', rettype'', retext, body')+  where+    checkReturnAlias rettp params' =+      foldM_ (checkReturnAlias' params') S.empty . returnAliasing rettp+    checkReturnAlias' params' seen (Unique, names)+      | any (`S.member` S.map snd seen) $ S.toList names =+        uniqueReturnAliased fname loc+      | otherwise = do+        notAliasingParam params' names+        pure $ seen `S.union` tag Unique names+    checkReturnAlias' _ seen (Nonunique, names)+      | any (`S.member` seen) $ S.toList $ tag Unique names =+        uniqueReturnAliased fname loc+      | otherwise = pure $ seen `S.union` tag Nonunique names++    notAliasingParam params' names =+      forM_ params' $ \p ->+        let consumedNonunique p' =+              not (unique $ unInfo $ identType p') && (identName p' `S.member` names)+         in case find consumedNonunique $ S.toList $ patIdents p of+              Just p' ->+                returnAliased fname (baseName $ identName p') loc+              Nothing ->+                pure ()++    tag u = S.map (u,)++    returnAliasing (Scalar (Record ets1)) (Scalar (Record ets2)) =+      concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2+    returnAliasing expected got =+      [(uniqueness expected, S.map aliasVar $ aliases got)]++-- | Extract all the shape names that occur in positive position+-- (roughly, left side of an arrow) in a given type.+typeDimNamesPos :: TypeBase (DimDecl VName) als -> S.Set VName+typeDimNamesPos (Scalar (Arrow _ _ t1 (RetType _ t2))) = onParam t1 <> typeDimNamesPos t2+  where+    onParam :: TypeBase (DimDecl VName) als -> S.Set VName+    onParam (Scalar Arrow {}) = mempty+    onParam (Scalar (Record fs)) = mconcat $ map onParam $ M.elems fs+    onParam (Scalar (TypeVar _ _ _ targs)) = mconcat $ map onTypeArg targs+    onParam t = typeDimNames t+    onTypeArg (TypeArgDim (NamedDim d) _) = S.singleton $ qualLeaf d+    onTypeArg (TypeArgDim _ _) = mempty+    onTypeArg (TypeArgType t _) = onParam t+typeDimNamesPos _ = mempty++checkGlobalAliases :: [Pat] -> PatType -> SrcLoc -> TermTypeM ()+checkGlobalAliases params body_t loc = do+  vtable <- asks $ scopeVtable . termScope+  let isLocal v = case v `M.lookup` vtable of+        Just (BoundV Local _ _) -> True+        _ -> False+  let als =+        filter (not . isLocal) . S.toList $+          boundArrayAliases body_t `S.difference` foldMap patNames params+  case als of+    v : _+      | not $ null params ->+        typeError loc mempty . withIndexLink "alias-free-variable" $+          "Function result aliases the free variable "+            <> pquote (pprName v)+            <> "."+            </> "Use" <+> pquote "copy" <+> "to break the aliasing."+    _ ->+      pure ()++inferReturnUniqueness :: [Pat] -> PatType -> PatType+inferReturnUniqueness params t =+  let forbidden = aliasesMultipleTimes t+      uniques = uniqueParamNames params+      delve (Scalar (Record fs)) =+        Scalar $ Record $ M.map delve fs+      delve t'+        | all (`S.member` uniques) (boundArrayAliases t'),+          not $ any ((`S.member` forbidden) . aliasVar) (aliases t') =+          t'+        | otherwise =+          t' `setUniqueness` Nonunique+   in delve t++-- An alias inhibits uniqueness if it is used in disjoint values.+aliasesMultipleTimes :: PatType -> Names+aliasesMultipleTimes = S.fromList . map fst . filter ((> 1) . snd) . M.toList . delve+  where+    delve (Scalar (Record fs)) =+      foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs+    delve t =+      M.fromList $ zip (map aliasVar $ S.toList (aliases t)) $ repeat (1 :: Int)++uniqueParamNames :: [Pat] -> Names+uniqueParamNames =+  S.map identName+    . S.filter (unique . unInfo . identType)+    . foldMap patIdents++boundArrayAliases :: PatType -> S.Set VName+boundArrayAliases (Array als _ _ _) = boundAliases als+boundArrayAliases (Scalar Prim {}) = mempty+boundArrayAliases (Scalar (Record fs)) = foldMap boundArrayAliases fs+boundArrayAliases (Scalar (TypeVar als _ _ _)) = boundAliases als+boundArrayAliases (Scalar Arrow {}) = mempty+boundArrayAliases (Scalar (Sum fs)) =+  mconcat $ concatMap (map boundArrayAliases) $ M.elems fs++nothingMustBeUnique :: SrcLoc -> TypeBase () () -> TermTypeM ()+nothingMustBeUnique loc = check+  where+    check (Array _ Unique _ _) = bad+    check (Scalar (TypeVar _ Unique _ _)) = bad+    check (Scalar (Record fs)) = mapM_ check fs+    check (Scalar (Sum fs)) = mapM_ (mapM_ check) fs+    check _ = pure ()+    bad = typeError loc mempty "A top-level constant cannot have a unique type."++-- | Verify certain restrictions on function parameters, and bail out+-- on dubious constructions.+--+-- These restrictions apply to all functions (anonymous or otherwise).+-- Top-level functions have further restrictions that are checked+-- during let-generalisation.+verifyFunctionParams :: Maybe Name -> [Pat] -> TermTypeM ()+verifyFunctionParams fname params =+  onFailure (CheckingParams fname) $+    verifyParams (foldMap patNames params) =<< mapM updateTypes params+  where+    verifyParams forbidden (p : ps)+      | d : _ <- S.toList $ patternDimNames p `S.intersection` forbidden =+        typeError p mempty . withIndexLink "inaccessible-size" $+          "Parameter" <+> pquote (ppr p)+            <+/> "refers to size" <+> pquote (pprName d)+            <> comma+            <+/> textwrap "which will not be accessible to the caller"+            <> comma+            <+/> textwrap "possibly because it is nested in a tuple or record."+            <+/> textwrap "Consider ascribing an explicit type that does not reference "+            <> pquote (pprName d)+            <> "."+      | otherwise = verifyParams forbidden' ps+      where+        forbidden' =+          case patternParam p of+            (Named v, _) -> forbidden `S.difference` S.singleton v+            _ -> forbidden+    verifyParams _ [] = pure ()++-- | Move existentials down to the level where they are actually used+-- (i.e. have their "witnesses").  E.g. changes+--+-- @+-- ?[n].bool -> [n]bool+-- @+--+-- to+--+-- @+-- bool -> ?[n].[n]bool+-- @+injectExt :: [VName] -> StructType -> StructRetType+injectExt [] ret = RetType [] ret+injectExt ext ret = RetType ext_here $ deeper ret+  where+    (immediate, _) = dimUses ret+    (ext_here, ext_there) = partition (`S.member` immediate) ext+    deeper (Scalar (Prim t)) = Scalar $ Prim t+    deeper (Scalar (Record fs)) = Scalar $ Record $ M.map deeper fs+    deeper (Scalar (Sum cs)) = Scalar $ Sum $ M.map (map deeper) cs+    deeper (Scalar (Arrow als p t1 (RetType t2_ext t2))) =+      Scalar $ Arrow als p t1 $ injectExt (ext_there <> t2_ext) t2+    deeper (Scalar (TypeVar as u tn targs)) =+      Scalar $ TypeVar as u tn $ map deeperArg targs+    deeper t@Array {} = t++    deeperArg (TypeArgType t loc) = TypeArgType (deeper t) loc+    deeperArg (TypeArgDim d loc) = TypeArgDim d loc++-- | Find all type variables in the given type that are covered by the+-- constraints, and produce type parameters that close over them.+--+-- The passed-in list of type parameters is always prepended to the+-- produced list of type parameters.+closeOverTypes ::+  Name ->+  SrcLoc ->+  [TypeParam] ->+  [StructType] ->+  StructType ->+  Constraints ->+  TermTypeM ([TypeParam], StructRetType, [VName])+closeOverTypes defname defloc tparams paramts ret substs = do+  (more_tparams, retext) <-+    partitionEithers . catMaybes+      <$> mapM closeOver (M.toList $ M.map snd to_close_over)+  let mkExt (NamedDim v) =+        case M.lookup (qualLeaf v) substs of+          Just (_, UnknowableSize {}) -> Just $ qualLeaf v+          _ -> Nothing+      mkExt ConstDim {} = Nothing+      mkExt AnyDim {} = error "closeOverTypes: AnyDim"+  return+    ( tparams ++ more_tparams,+      injectExt (mapMaybe mkExt (nestedDims ret)) ret,+      retext+    )+  where+    t = foldFunType paramts $ RetType [] ret+    to_close_over = M.filterWithKey (\k _ -> k `S.member` visible) substs+    visible = typeVars t <> typeDimNames t++    (produced_sizes, param_sizes) = dimUses t++    -- Avoid duplicate type parameters.+    closeOver (k, _)+      | k `elem` map typeParamName tparams =+        pure Nothing+    closeOver (k, NoConstraint l usage) =+      pure $ Just $ Left $ TypeParamType l k $ srclocOf usage+    closeOver (k, ParamType l loc) =+      pure $ Just $ Left $ TypeParamType l k loc+    closeOver (k, Size Nothing usage) =+      pure $ Just $ Left $ TypeParamDim k $ srclocOf usage+    closeOver (k, UnknowableSize _ _)+      | k `S.member` param_sizes,+        k `S.notMember` produced_sizes = do+        notes <- dimNotes defloc $ NamedDim $ qualName k+        typeError defloc notes . withIndexLink "unknowable-param-def" $+          "Unknowable size" <+> pquote (pprName k)+            <+> "in parameter of"+            <+> pquote (pprName defname)+            <> ", which is inferred as:"+            </> indent 2 (ppr t)+      | k `S.member` produced_sizes =+        pure $ Just $ Right k+    closeOver (_, _) =+      pure Nothing++letGeneralise ::+  Name ->+  SrcLoc ->+  [TypeParam] ->+  [Pat] ->+  StructType ->+  TermTypeM ([TypeParam], [Pat], StructRetType, [VName])+letGeneralise defname defloc tparams params rettype =+  onFailure (CheckingLetGeneralise defname) $ do+    now_substs <- getConstraints++    -- Candidates for let-generalisation are those type variables that+    --+    -- (1) were not known before we checked this function, and+    --+    -- (2) are not used in the (new) definition of any type variables+    -- known before we checked this function.+    --+    -- (3) are not referenced from an overloaded type (for example,+    -- are the element types of an incompletely resolved record type).+    -- This is a bit more restrictive than I'd like, and SML for+    -- example does not have this restriction.+    --+    -- Criteria (1) and (2) is implemented by looking at the binding+    -- level of the type variables.+    let keep_type_vars = overloadedTypeVars now_substs++    cur_lvl <- curLevel+    let candidate k (lvl, _) = (k `S.notMember` keep_type_vars) && lvl >= cur_lvl+        new_substs = M.filterWithKey candidate now_substs++    (tparams', RetType ret_dims rettype', retext) <-+      closeOverTypes+        defname+        defloc+        tparams+        (map patternStructType params)+        rettype+        new_substs++    rettype'' <- updateTypes rettype'++    let used_sizes =+          foldMap typeDimNames $ rettype'' : map patternStructType params+    case filter ((`S.notMember` used_sizes) . typeParamName) $+      filter isSizeParam tparams' of+      [] -> pure ()+      tp : _ -> unusedSize $ SizeBinder (typeParamName tp) (srclocOf tp)++    -- We keep those type variables that were not closed over by+    -- let-generalisation.+    modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` map typeParamName tparams'++    pure (tparams', params, RetType ret_dims rettype'', retext)++checkFunBody ::+  [Pat] ->+  UncheckedExp ->+  Maybe StructType ->+  SrcLoc ->+  TermTypeM Exp+checkFunBody params body maybe_rettype loc = do+  body' <- noSizeEscape $ checkExp body++  -- Unify body return type with return annotation, if one exists.+  case maybe_rettype of+    Just rettype -> do+      body_t <- expTypeFully body'+      -- We need to turn any sizes provided by "hidden" parameter+      -- names into existential sizes instead.+      let hidden = hiddenParamNames params+      (body_t', _) <-+        unscopeType+          loc+          ( M.filterWithKey (const . (`S.member` hidden)) $+              foldMap patternMap params+          )+          body_t++      let usage = mkUsage (srclocOf body) "return type annotation"+      onFailure (CheckingReturn rettype (toStruct body_t')) $+        expect usage rettype $ toStruct body_t'++      -- We also have to make sure that uniqueness matches.  This is done+      -- explicitly, because uniqueness is ignored by unification.+      rettype' <- normTypeFully rettype+      body_t'' <- normTypeFully rettype -- Substs may have changed.+      unless (toStructural body_t'' `subtypeOf` toStructural rettype') $+        typeError (srclocOf body) mempty $+          "Body type" </> indent 2 (ppr body_t'')+            </> "is not a subtype of annotated type"+            </> indent 2 (ppr rettype')+    Nothing -> pure ()++  pure body'++arrayOfM ::+  (Pretty (ShapeDecl dim), Monoid as) =>+  SrcLoc ->+  TypeBase dim as ->+  ShapeDecl dim ->+  Uniqueness ->+  TermTypeM (TypeBase dim as)+arrayOfM loc t shape u = do+  arrayElemType (mkUsage loc "use as array element") "type used in array" t+  pure $ arrayOf t shape u