futhark 0.24.3 → 0.25.1

raw patch · 146 files changed

+9745/−7916 lines, 146 filesdep +lsp-typesdep ~freedep ~lspdep ~versionsPVP ok

version bump matches the API change (PVP)

Dependencies added: lsp-types

Dependency ranges changed: free, lsp, versions

API changes (from Hackage documentation)

Files

• docs/c-api.rst +2/−2
• docs/error-index.rst +87/−10
• docs/glossary.rst +19/−1
• docs/language-reference.rst +65/−102
• docs/man/futhark-test.rst +15/−12
• docs/man/futhark.rst +4/−4
• futhark.cabal +11/−4
• prelude/array.fut +35/−39
• prelude/soacs.fut +5/−3
• src/Futhark/AD/Fwd.hs +0/−6
• src/Futhark/AD/Rev.hs +5/−12
• src/Futhark/AD/Rev/Hist.hs +6/−2
• src/Futhark/AD/Rev/Loop.hs +2/−1
• src/Futhark/AD/Rev/Monad.hs +8/−2
• src/Futhark/AD/Rev/Reduce.hs +8/−18
• src/Futhark/AD/Rev/Scatter.hs +3/−1
• src/Futhark/Analysis/AlgSimplify.hs +1/−1
• src/Futhark/Analysis/Metrics.hs +0/−2
• src/Futhark/Analysis/PrimExp/Convert.hs +2/−2
• src/Futhark/Analysis/SymbolTable.hs +3/−2
• src/Futhark/CLI/Dev.hs +24/−3
• src/Futhark/CLI/Doc.hs +6/−5
• src/Futhark/CLI/Eval.hs +8/−1
• src/Futhark/CLI/LSP.hs +5/−5
• src/Futhark/CLI/Literate.hs +8/−11
• src/Futhark/CLI/Main.hs +1/−1
• src/Futhark/CLI/REPL.hs +1/−1
• src/Futhark/CLI/Test.hs +28/−13
• src/Futhark/CodeGen/Backends/GenericC.hs +5/−4
• src/Futhark/CodeGen/Backends/GenericC/Types.hs +2/−2
• src/Futhark/CodeGen/Backends/GenericPython.hs +1/−1
• src/Futhark/CodeGen/Backends/PyOpenCL.hs +1/−1
• src/Futhark/CodeGen/Backends/SimpleRep.hs +2/−3
• src/Futhark/CodeGen/ImpGen.hs +3/−18
• src/Futhark/CodeGen/ImpGen/GPU.hs +88/−33
• src/Futhark/CodeGen/ImpGen/GPU/Base.hs +0/−23
• src/Futhark/CodeGen/ImpGen/GPU/Group.hs +1/−11
• src/Futhark/CodeGen/ImpGen/GPU/Transpose.hs +111/−103
• src/Futhark/Construct.hs +2/−2
• src/Futhark/Doc/Generator.hs +28/−29
• src/Futhark/IR/GPUMem.hs +4/−0
• src/Futhark/IR/MCMem.hs +5/−0
• src/Futhark/IR/Mem.hs +4/−1
• src/Futhark/IR/Mem/IxFun.hs +4/−433
• src/Futhark/IR/Mem/LMAD.hs +470/−0
• src/Futhark/IR/Mem/Simplify.hs +1/−1
• src/Futhark/IR/Parse.hs +33/−15
• src/Futhark/IR/Pretty.hs +13/−8
• src/Futhark/IR/Prop.hs +0/−1
• src/Futhark/IR/Prop/Aliases.hs +32/−40
• src/Futhark/IR/Prop/Names.hs +1/−1
• src/Futhark/IR/Prop/TypeOf.hs +1/−5
• src/Futhark/IR/Prop/Types.hs +3/−0
• src/Futhark/IR/Rephrase.hs +2/−1
• src/Futhark/IR/RetType.hs +1/−1
• src/Futhark/IR/SOACS/Simplify.hs +6/−23
• src/Futhark/IR/SegOp.hs +2/−2
• src/Futhark/IR/Syntax.hs +22/−9
• src/Futhark/IR/Syntax/Core.hs +7/−12
• src/Futhark/IR/Traversals.hs +4/−11
• src/Futhark/IR/TypeCheck.hs +70/−88
• src/Futhark/Internalise.hs +10/−4
• src/Futhark/Internalise/Bindings.hs +52/−25
• src/Futhark/Internalise/Defunctionalise.hs +288/−313
• src/Futhark/Internalise/Defunctorise.hs +6/−4
• src/Futhark/Internalise/Entry.hs +8/−3
• src/Futhark/Internalise/Exps.hs +121/−125
• src/Futhark/Internalise/FullNormalise.hs +367/−0
• src/Futhark/Internalise/LiftLambdas.hs +68/−50
• src/Futhark/Internalise/Monad.hs +3/−7
• src/Futhark/Internalise/Monomorphise.hs +650/−303
• src/Futhark/Internalise/ReplaceRecords.hs +146/−0
• src/Futhark/Internalise/TypesValues.hs +213/−58
• src/Futhark/LSP/Compile.hs +2/−2
• src/Futhark/LSP/Diagnostic.hs +46/−25
• src/Futhark/LSP/Handlers.hs +52/−42
• src/Futhark/LSP/Tool.hs +3/−3
• src/Futhark/Optimise/ArrayShortCircuiting.hs +7/−2
• src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs +180/−160
• src/Futhark/Optimise/ArrayShortCircuiting/DataStructs.hs +17/−13
• src/Futhark/Optimise/ArrayShortCircuiting/MemRefAggreg.hs +9/−2
• src/Futhark/Optimise/ArrayShortCircuiting/TopdownAnalysis.hs +14/−24
• src/Futhark/Optimise/CSE.hs +19/−13
• src/Futhark/Optimise/DoubleBuffer.hs +9/−6
• src/Futhark/Optimise/Fusion.hs +1/−1
• src/Futhark/Optimise/GenRedOpt.hs +0/−1
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +2/−2
• src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +3/−16
• src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs +4/−16
• src/Futhark/Optimise/Simplify/Engine.hs +17/−4
• src/Futhark/Optimise/Simplify/Rep.hs +1/−1
• src/Futhark/Optimise/Simplify/Rules.hs +11/−11
• src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +14/−56
• src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs +1/−1
• src/Futhark/Optimise/Simplify/Rules/Index.hs +3/−18
• src/Futhark/Optimise/Simplify/Rules/Loop.hs +1/−1
• src/Futhark/Optimise/Simplify/Rules/Simple.hs +7/−7
• src/Futhark/Optimise/TileLoops.hs +13/−18
• src/Futhark/Pass.hs +1/−1
• src/Futhark/Pass/AD.hs +2/−2
• src/Futhark/Pass/ExpandAllocations.hs +1/−1
• src/Futhark/Pass/ExplicitAllocations.hs +22/−5
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +10/−11
• src/Futhark/Pass/ExtractKernels/Interchange.hs +4/−1
• src/Futhark/Pass/ExtractKernels/Intragroup.hs +1/−1
• src/Futhark/Pass/KernelBabysitting.hs +7/−22
• src/Futhark/Pass/LiftAllocations.hs +74/−83
• src/Futhark/Pass/LowerAllocations.hs +17/−33
• src/Futhark/Pkg/Types.hs +5/−5
• src/Futhark/Test.hs +2/−2
• src/Futhark/Transform/FirstOrderTransform.hs +5/−6
• src/Futhark/Transform/Rename.hs +14/−1
• src/Futhark/Util.hs +38/−1
• src/Futhark/Util/Pretty.hs +9/−4
• src/Language/Futhark.hs +0/−80
• src/Language/Futhark/Core.hs +15/−0
• src/Language/Futhark/FreeVars.hs +42/−55
• src/Language/Futhark/Interpreter.hs +244/−181
• src/Language/Futhark/Interpreter/Values.hs +12/−8
• src/Language/Futhark/Parser.hs +13/−2
• src/Language/Futhark/Parser/Lexer.x +1/−1
• src/Language/Futhark/Parser/Lexer/Tokens.hs +1/−1
• src/Language/Futhark/Parser/Monad.hs +33/−7
• src/Language/Futhark/Parser/Parser.y +23/−21
• src/Language/Futhark/Pretty.hs +36/−28
• src/Language/Futhark/Primitive.hs +3/−0
• src/Language/Futhark/Prop.hs +1516/−1397
• src/Language/Futhark/Query.hs +5/−7
• src/Language/Futhark/Syntax.hs +162/−130
• src/Language/Futhark/Traversals.hs +97/−94
• src/Language/Futhark/TypeChecker.hs +28/−27
• src/Language/Futhark/TypeChecker/Consumption.hs +972/−0
• src/Language/Futhark/TypeChecker/Match.hs +2/−2
• src/Language/Futhark/TypeChecker/Modules.hs +41/−46
• src/Language/Futhark/TypeChecker/Monad.hs +28/−31
• src/Language/Futhark/TypeChecker/Terms.hs +1704/−1700
• src/Language/Futhark/TypeChecker/Terms/DoLoop.hs +179/−325
• src/Language/Futhark/TypeChecker/Terms/Monad.hs +145/−477
• src/Language/Futhark/TypeChecker/Terms/Pat.hs +87/−171
• src/Language/Futhark/TypeChecker/Types.hs +98/−253
• src/Language/Futhark/TypeChecker/Unify.hs +145/−173
• unittests/Futhark/IR/SyntaxTests.hs +19/−2
• unittests/Futhark/Internalise/TypesValuesTests.hs +173/−0
• unittests/Language/Futhark/SyntaxTests.hs +43/−29
• unittests/Language/Futhark/TypeChecker/TypesTests.hs +5/−4
• unittests/futhark_tests.hs +2/−0

@@ -293,7 +293,7 @@ tuples, etc) is represented by an opaque C struct named ``futhark_opaque_foo``.  In the general case, ``foo`` will be a hash of the internal representation.  However, if you insert an explicit-type annotations in the entry point (and the type name contains only+type annotation in the entry point (and the type name contains only characters valid in C identifiers), that name will be used.  Note that arrays contain brackets, which are not valid in identifiers.  Defining a type abbreviation is the best way around this.@@ -645,7 +645,7 @@   * For opaques that are actually records (including tuples):      * The list of fields, including their type and a projection-      function.  The field ordering here is the one used expected by+      function.  The field ordering here is the one expected by       the *new* function.      * The name of the C *new* function for creating a record from

@@ -267,6 +267,44 @@    def f () = copy x +.. _size-expression-bind:++"Size expression with binding is replaced by unknown size."+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To illustrate this error, consider the following program++.. code-block:: futhark++   def main (xs: *[]i64) =+     let a = iota (let n = 10 in n+n)+     in ...++Intuitively, the type of ``a`` should be ``[let n = 10 in n+n]i32``,+but this puts a binding into a size expression, which is invalid.+Therefore, the type checker invents an :term:`unknown size`+variable, say ``l``, and assigns ``a`` the type ``[l]i32``.++.. _size-expression-consume:++"Size expression with consumption is replaced by unknown size."+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To illustrate this error, consider the following program++.. code-block:: futhark++   def consume (xs: *[]i64): i64 = xs[0]++   def main (xs: *[]i64) =+     let a = iota (consume xs)+     in ...++Intuitively, the type of ``a`` should be ``[consume ys]i32``, but this+puts a consumption of the array ``ys`` into a size expression, which+is invalid.  Therefore, the type checker invents an :term:`unknown+size` variable, say ``l``, and assigns ``a`` the type ``[l]i32``.+ .. _inaccessible-size:  "Parameter *x* refers to size *y* which will not be accessible to the caller@@ -378,14 +416,14 @@ In many other cases, we can lift out the "size-producing" expressions into a separate ``let``-binding preceding the problematic expressions. -.. _unknowable-param-def:+.. _unknown-param-def: -"Unknowable size *x* in parameter of *y*"-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"Unknown 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:+an :term:`unknown size`.  Somewhat contrived example:  .. code-block:: futhark @@ -471,8 +509,9 @@ "Existential size *n* not used as array size" ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This error occurs for type expressions that use explicit existential-quantification in an incorrect way, such as the following examples:+This error occurs for type expressions that bind an existential size+for which there is no :term:`constructive use`, such as in the+following examples:  .. code-block:: futhark @@ -481,12 +520,12 @@   ?[n].bool -> [n]bool  When we use existential quantification, we are required to use the-size within its scope, *and* it must not exclusively be used to the-right of function arrow.+size constructively within its scope, *in particular* it must not be+exclusively as the parameter or return type of a function.  To understand the motivation behind this rule, consider that when we-use an existential quantifier we are saying that there is *some size*,-it just cannot be known statically, but must be read from some value+use an existential quantifier we are saying that there is *some size*.+The size is not known statically, but must be read from some value (i.e. array) at runtime.  In the first example above, the existential size ``n`` is not used at all, so the actual value cannot be determined at runtime.  In the second example, while an array@@ -943,3 +982,41 @@ .. code-block:: futhark     entry f (n: i64) : [0][n]i32 = []++.. _nonconstructive-entry:++"Entry point size parameter [n] only used non-constructively."+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This error occurs for programs such as the following::++.. code-block:: futhark++   entry main [x] (A: [x+1]i32) = ...++The size parameter ``[x]`` is only used in an size expression ``x+1``,+rather than directly as an array size.  This is allowed for ordinary+functions, but not for entry points.  The reason is that entry points+are not subject to ordinary type inference, as they are called from+the external world, meaning that the value of the size parameter+``[x]`` will have to be determined from the size of the array ``A``.+This is in principle not a problem for simple sizes like ``x+1``, as+it is obvious that ``x == length A - 1``, but in the general case it+would require computing function inverses that might not exist.  For+this reason, entry points require that all size parameters are used+:term:`constructively<constructive use>`.++As a workaround, you can rewrite the entry point as follows:++.. code-block:: futhark++   entry main [n] (A: [n]i32) =+     let x = n-1+     let A = A :> [x+1]i32+     ...++Or by passing the ``x`` explicitly:++.. code-block:: futhark++   entry main (x: i64) (A: [x+1]i32) = ...

@@ -73,11 +73,13 @@         * ``[n]bool``        * ``([n]bool, bool -> [n]bool)``+       * ``([n]bool, [n+1]bool)``       The following do not:         * ``[n+1]bool``        * ``bool -> [n]bool``+       * ``[n]bool -> bool``     Consumption @@ -296,6 +298,20 @@       The symbolic size of an array dimension or :term:`abstract type`. +   Size expression++     An expression that occurs as the size of an array or size+     argument.  For example, in the type ``[x+2]i32``, ``x+2`` is a+     size expression.  Size expressions can occur syntactically in+     source code, or due to parameter substitution when applying a+     :term:`size-dependent function`.++   Size-dependent function++     A function where the size of the result depends on the values of+     the parameters.  The function ``iota`` is perhaps the simplest+     example.+    Size types    Size-dependent types @@ -385,7 +401,9 @@    Unknown size       A size produced by invoking a function whose result type contains-     an existentially quantified size, such as ``filter``.+     an existentially quantified size, such as ``filter``, or because+     the original :term:`size expression` involves variables that have+     gone out of scope.     Value 

@@ -117,9 +117,8 @@  Compound types can be constructed based on the primitive types.  The Futhark type system is entirely structural, and type abbreviations are-merely shorthands (with one exception, see-:ref:`sizes-in-abbreviations`).  The only exception is abstract types-whose definition has been hidden via the module system (see+merely shorthands.  The only exception is abstract types whose+definition has been hidden via the module system (see :ref:`module-system`).  .. productionlist::@@ -136,18 +135,17 @@ and are of type ``()``.  .. productionlist::-   array_type: "[" [`dim`] "]" `type`-   dim: `qualid` | `decimal`+   array_type: "[" [`exp`] "]" `type`  An array value is written as a sequence of zero or more comma-separated values enclosed in square brackets: ``[1,2,3]``.  An 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.  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).+the array, and ``d`` is an expression of type ``i64`` indicating the+number of elements in the array.  We can elide ``d`` and write just+``[]`` (an :term:`anonymous size`), 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@@ -220,7 +218,7 @@  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.+unknown array sizes.  Declarations ------------@@ -268,10 +266,9 @@  Hindley-Milner-style type inference is supported.  A parameter may be given a type with the notation ``(name: type)``.  Functions may not be-recursive.  You may put *size annotations* in the return type and-parameter types; see `Size Types`_.  A function can be *polymorphic*-by using type parameters, in the same way as for `Type-Abbreviations`_::+recursive.  The sizes of the arguments can be constrained - see `Size+Types`_.  A function can be *polymorphic* by using type parameters, in+the same way as for `Type Abbreviations`_::    def reverse [n] 't (xs: [n]t): [n]t = xs[::-1] @@ -405,9 +402,9 @@    def x: two_intvecs [2] = (iota 2, replicate 2 0) -Size parameters work much like shape declarations for arrays.  Like-shape declarations, they can be elided via square brackets containing-nothing.  All size parameters must be used in the definition of the+When referencing a type abbreviation, size parameters work much like+array sizes.  Like sizes, they can be passed an anonymous size+(``[]``).  All size parameters must be used in the definition of the type abbreviation.  A type parameter prefixed with a single quote is a *type parameter*.@@ -448,7 +445,6 @@        : | "(" `exp` ")" "[" `index` ("," `index`)* "]"        : | `quals` "." "(" `exp` ")"        : | "[" `exp` ("," `exp`)* "]"-       : | "[" `exp` [".." `exp`] "..." `exp` "]"        : | "(" `qualbinop` ")"        : | "(" `exp` `qualbinop` ")"        : | "(" `qualbinop` `exp` ")"@@ -579,6 +575,7 @@   left               ``|>``   right              ``<|``   right              ``->``+  left               ``**``   left               juxtaposition   =================  ============= @@ -939,6 +936,10 @@ let-generalised, meaning it has a monomorphic type.  This can be significant if ``e`` is of functional type. +If ``e`` is of type ``i64`` and ``pat`` binds only a single name+``v``, then the type of the overall expression is the type of+``body``, but with any occurence of ``v`` replaced by ``e``.+ ``let [n] pat = e in body`` ........................... @@ -1092,34 +1093,34 @@ Size Types ---------- -Futhark supports a simple system of size-dependent types that-statically verifies that the sizes of arrays passed to a function are-compatible.  The focus is on simplicity, not completeness.+Futhark supports a system of size-dependent types that statically+checks that the sizes of arrays passed to a function are compatible.  Whenever a pattern occurs (in ``let``, ``loop``, and function-parameters), as well as in return types, *size annotations* may be-used to express invariants about the shapes of arrays that are-accepted or produced by the function.  For example::+parameters), as well as in return types, the types of the bindings+express invariants about the shapes of arrays that are accepted or+produced by the function.  For example::    def f [n] (a: [n]i32) (b: [n]i32): [n]i32 =     map2 (+) a b -We use a *size parameter*, ``[n]``, to explicitly quantify sizes.  The-``[n]`` parameter is not explicitly passed when calling ``f``.+We use a *size parameter*, ``[n]``, to explicitly quantify a size.+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 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::+the value parameters.  An array type can contain *anonymous sizes*,+e.g. ``[]i32``, for which the type checker will invent fresh size+parameters, which ensures that all arrays have a 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-constraints imposed by size annotations.+Sizes can be any expression of type ``i64`` that does not consume any+free variables.  Size parameters can be used as ordinary variables of+type ``i64`` within the scope of the parameters.  The type checker+verifies that the program obeys any constraints imposed by size+annotations.  *Size-dependent types* are supported, as the names of parameters can be used in the return type of a function::@@ -1128,30 +1129,29 @@  An application ``replicate 10 0`` will have type ``[10]i32``. -Whenever we write a type ``[n]t``, ``n`` must already be a variable of-type ``i64`` in scope (possibly by being bound as a size parameter).+Whenever we write a type ``[e]t``, ``e`` must be a well-typed+expression of type ``i64`` in scope (possibly by referencing names+bound as a size parameter).  .. _unknown-sizes:  Unknown sizes ~~~~~~~~~~~~~ -Since sizes must be constants or variables, there are many cases where-the type checker cannot assign a precise size to the result of some-operation.  For example, the type of ``concat`` should conceptually be::--  val concat [n] [m] 't : [n]t -> [m]t -> [n+m]t+There are cases where the type checker cannot assign a precise size to+the result of some operation.  For example, the type of ``filter``+is:: -But this is not presently allowed.  Instead, the return type contains-an existential size::+  val filter [n] 'a : (a -> bool) -> [n]t -> ?[m].[m]t -  val concat [n] [m] 't : [n]t -> [m]t -> ?[k].[k]t+The function returns of an array of *some existential size* ``m``, but+it cannot be known in advance. -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-convert an unknown size to a known size.+When an application ``filter p xs`` is found, the result will be of+type ``[k]t``, where ``k`` is a fresh *unknown size* that is+considered distinct from every other size in the program.  It is+sometimes 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 be expressed.  The following lists all possible sources of unknown@@ -1160,22 +1160,22 @@ Size going out of scope ....................... -An unknown size is created when the proper size of an array refers to-a name that has gone out of scope::+An unknown size is created in some cases when the a type references a+name that has gone out of scope:: -  let c = a + b-  in replicate c 0+  match ...+  case #some c -> replicate c 0  The type of ``replicate c 0`` is ``[c]i32``, but since ``c`` is locally bound, the type of the entire expression is ``[k]i32`` for some fresh ``k``. -Compound expression passed as function argument-...............................................+Consuming expression passed as function argument+................................................ -Intuitively, the type of ``replicate (x+y) 0`` should be ``[x+y]i32``,-but since sizes must be names or constants, this is not expressible.-Therefore an unknown size variable is created and the size of the+The type of ``replicate e 0`` should be ``[e]i32``, but if ``e`` is an+expression that is not valid as a size, this is not expressible.+Therefore an unknown size ``k`` is created and the size of the expression becomes ``[k]i32``.  Compound expression used as range bound@@ -1251,17 +1251,12 @@ ~~~~~~~~~~~~~  Size coercion, written with ``:>``, can be used to perform a-runtime-checked coercion of one size to another.  Since size-annotations can refer only to variables and constants, this is-necessary when writing more complicated size functions::+runtime-checked coercion of one size to another.  This can be useful+as an escape hatch in the size type system::    def concat_to 'a (m: i32) (a: []a) (b: []a) : [m]a =     a ++ b :> [m]a -Only expression-level type annotations give rise to run-time checks.-Despite their similar syntax, parameter and return type annotations-must be valid at compile-time, or type checking will fail.- .. _causality:  Causality restriction@@ -1379,39 +1374,7 @@ be passed to ``map``, as explained before.  The solution is to bind ``length`` to a name *before* the lambda. -.. _sizes-in-abbreviations: -Sizes in type abbreviations-~~~~~~~~~~~~~~~~~~~~~~~~~~~--When anonymous sizes are passed to type abbreviations, if that-anonymous size is eventually instantiated with an existential size,-the *same* existential size is going to be used for all instances of-the corresponding parameter in the right-hand-side of the type-abbreviation.  Note that this breaks with the usual conception of type-abbreviations as purely a shorthand, as this could not be expressed-without the abbreviation.  Example::--  type square [n] = [n][n]i32--The following function is be *known* to return a square array::--  val f : () -> square []--But this is not the case for the function that inlines the definition-of ``square``::--  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@@ -1554,7 +1517,7 @@ .. productionlist::    mod_exp:   `qualid`           : | `mod_exp` ":" `mod_type_exp`-          : | "\" "(" `id` ":" `mod_type_exp` ")" [":" `mod_type_exp`] "->" `mod_exp`+          : | "\" "(" `mod_param`* ")" [":" `mod_type_exp`] "->" `mod_exp`           : | `mod_exp` `mod_exp`           : | "(" `mod_exp` ")"           : | "{" `dec`* "}"

@@ -55,8 +55,8 @@ braces must consist of a sequence of Futhark types, including sizes in the case of arrays.  When ``futhark test`` is run, a file located in a ``data/`` subdirectory, containing values of the indicated types and-shapes is, automatically constructed with ``futhark-dataset``.  Apart-from sizes, integer constants (with or without type suffix), and+shapes is, automatically constructed with :ref:`futhark-dataset(1)`.+Apart from sizes, integer constants (with or without type suffix), and floating-point constants (always with type suffix) are also permitted.  If ``input`` is preceded by ``script``, the text between the curly@@ -68,22 +68,21 @@ The only builtin function supported is ``$loaddata``.  If ``input`` is followed by an ``@`` and a file name (which must not-contain any whitespace) instead of curly braces, values or-FutharkScript expression will be read from the indicated file.  This-is recommended for large data sets.  This notation cannot be used with-``random`` input.+contain any whitespace) instead of curly braces, values will be read+from the indicated file.  This is recommended for large data sets.+This notation cannot be used with ``random`` input.  With ``script+input``, the file contents will be interpreted as a FutharkScript+expression.  After the ``input`` block, the expected result of the test case is written as either ``output`` followed by another block of values, or-an expected run-time error, in which a regular expression can be used-to specify the exact error message expected.  If no regular expression-is given, any error message is accepted.  If neither ``output`` nor-``error`` is given, the program will be expected to execute-succesfully, but its output will not be validated.+``error:`` followed by a regex indicating an expected run-time error.+If neither ``output`` nor ``error`` is given, the program will be+expected to execute succesfully, but its output will not be validated.  If ``output`` is preceded by ``auto`` (as in ``auto output``), the expected values are automatically generated by compiling the program-with ``futhark-c`` and recording its result for the given input (which+with ``futhark c`` and recording its result for the given input (which must not fail).  This is usually only useful for testing or benchmarking alternative compilers, and not for testing the correctness of Futhark programs.  This currently does not work for@@ -157,6 +156,10 @@  -i   Test with the interpreter.++-I+  Pass the program through the compiler frontend, but do not run them.+  This is only useful for testing the Futhark compiler itself.  -t   Type-check the programs, but do not run them.

@@ -27,9 +27,9 @@ futhark benchcmp FILE_A FILE_B ------------------------------ -Compares two Futhark benchmarks and reports changes in performance.-The files must be formatted in the same manner as a JSON file returned-from :ref:`futhark-bench(1)`.+Compare two JSON files produced by the ``--json`` option of+:ref:`futhark-bench(1)`.  The results show speedup of the latter file+compared to the former.  futhark check [-w] PROGRAM --------------------------@@ -76,7 +76,7 @@ futhark eval [-f FILE] [-w] <exprs...> -------------------------------------- -Evaluates expressions given as command-line arguments. Optionally +Evaluates expressions given as command-line arguments. Optionally allows a file import using ``-f``.  futhark hash PROGRAM

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:           futhark-version:        0.24.3+version:        0.25.1 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -288,6 +288,7 @@       Futhark.IR.Mem       Futhark.IR.Mem.Interval       Futhark.IR.Mem.IxFun+      Futhark.IR.Mem.LMAD       Futhark.IR.Mem.Simplify       Futhark.IR.Parse       Futhark.IR.Pretty@@ -321,10 +322,12 @@       Futhark.Internalise.Defunctorise       Futhark.Internalise.Entry       Futhark.Internalise.Exps+      Futhark.Internalise.FullNormalise       Futhark.Internalise.Lambdas       Futhark.Internalise.LiftLambdas       Futhark.Internalise.Monad       Futhark.Internalise.Monomorphise+      Futhark.Internalise.ReplaceRecords       Futhark.Internalise.TypesValues       Futhark.LSP.Compile       Futhark.LSP.Diagnostic@@ -440,6 +443,7 @@       Language.Futhark.Traversals       Language.Futhark.Tuple       Language.Futhark.TypeChecker+      Language.Futhark.TypeChecker.Consumption       Language.Futhark.TypeChecker.Match       Language.Futhark.TypeChecker.Modules       Language.Futhark.TypeChecker.Monad@@ -481,7 +485,7 @@     , fgl-visualize     , file-embed >=0.0.14.0     , filepath >=1.4.1.1-    , free >=4.12.4+    , free >=5.1.10     , futhark-data >= 1.1.0.0     , futhark-server >= 1.2.2.1     , futhark-manifest >= 1.2.0.1@@ -490,7 +494,8 @@     , haskeline     , language-c-quote >= 0.12     , lens-    , lsp >= 1.5.0+    , lsp >= 2.0.0.0+    , lsp-types >= 2.0.0.0     , mainland-pretty >=0.7.1     , cmark-gfm >=0.2.1     , megaparsec >=9.0.0@@ -508,7 +513,7 @@     , time >=1.6.0.1     , transformers >=0.3     , vector >=0.12-    , versions >=5.0.0+    , versions >=6.0.0     , zlib >=0.6.1.2     , statistics     , mwc-random@@ -531,6 +536,7 @@       Futhark.BenchTests       Futhark.Pkg.SolveTests       Futhark.Analysis.AlgSimplifyTests+      Futhark.Internalise.TypesValuesTests       Futhark.IR.Prop.RearrangeTests       Futhark.IR.Prop.ReshapeTests       Futhark.IR.PropTests@@ -551,6 +557,7 @@       QuickCheck >=2.8     , base     , containers+    , free     , futhark     , megaparsec     , tasty

@@ -28,12 +28,12 @@ -- | Everything but the first element of the array. -- -- **Complexity:** O(1).-def tail [n] 't (x: [n]t) = x[1:]+def tail [n] 't (x: [n]t): [n-1]t = x[1:]  -- | Everything but the last element of the array. -- -- **Complexity:** O(1).-def init [n] 't (x: [n]t) = x[0:n-1]+def init [n] 't (x: [n]t): [n-1]t = x[0:n-1]  -- | Take some number of elements from the head of the array. --@@ -43,13 +43,18 @@ -- | Remove some number of elements from the head of the array. -- -- **Complexity:** O(1).-def drop [n] 't (i: i64) (x: [n]t) = x[i:]+def drop [n] 't (i: i64) (x: [n]t): [n-i]t = x[i:] +-- | Statically change the size of an array.  Fail at runtime if the+-- imposed size does not match the actual size.  Essentially syntactic+-- sugar for a size coercion.+def sized [m] 't (n: i64) (xs: [m]t) : [n]t = xs :> [n]t+ -- | Split an array at a given position. -- -- **Complexity:** O(1).-def split [n] 't (i: i64) (xs: [n]t): ([i]t, []t) =-  (xs[0:i], xs[i:])+def split [n][m] 't (xs: [n+m]t): ([n]t, [m]t) =+  (xs[0:n], xs[n:n+m] :> [m]t)  -- | Return the elements of the array in reverse order. --@@ -62,28 +67,10 @@ -- **Work:** O(n). -- -- **Span:** O(1).-def (++) [n] [m] 't (xs: [n]t) (ys: [m]t): *[]t = intrinsics.concat xs ys+def (++) [n] [m] 't (xs: [n]t) (ys: [m]t): *[n+m]t = intrinsics.concat xs ys  -- | An old-fashioned way of saying `++`.-def concat [n] [m] 't (xs: [n]t) (ys: [m]t): *[]t = xs ++ ys---- | Concatenation where the result has a predetermined size.  If the--- provided size is wrong, the function will fail with a run-time--- error.-def concat_to [n] [m] 't (k: i64) (xs: [n]t) (ys: [m]t): *[k]t = xs ++ ys :> [k]t---- | Rotate an array some number of elements to the left.  A negative--- rotation amount is also supported.------ For example, if `b==rotate r a`, then `b[x] = a[x+r]`.------ **Work:** O(n).------ **Span:** O(1).------ Note: In most cases, `rotate` will be fused with subsequent--- operations such as `map`, in which case it is free.-def rotate [n] 't (r: i64) (xs: [n]t): [n]t = intrinsics.rotate r xs+def concat [n] [m] 't (xs: [n]t) (ys: [m]t): *[n+m]t = xs ++ ys  -- | Construct an array of consecutive integers of the given length, -- starting at 0.@@ -103,6 +90,20 @@ def indices [n] 't (_: [n]t) : *[n]i64 =   iota n +-- | Rotate an array some number of elements to the left.  A negative+-- rotation amount is also supported.+--+-- For example, if `b==rotate r a`, then `b[x] = a[x+r]`.+--+-- **Work:** O(n).+--+-- **Span:** O(1).+--+-- Note: In most cases, `rotate` will be fused with subsequent+-- operations such as `map`, in which case it is free.+def rotate [n] 't (r: i64) (a: [n]t) =+  map (\i -> #[unsafe] a[(i+r)%n]) (iota n)+ -- | Construct an array of the given length containing the given -- value. --@@ -123,35 +124,30 @@ -- | Combines the outer two dimensions of an array. -- -- **Complexity:** O(1).-def flatten [n][m] 't (xs: [n][m]t): []t =+def flatten [n][m] 't (xs: [n][m]t): [n*m]t =   intrinsics.flatten xs --- | Like `flatten`@term, but where the final size is known.  Fails at--- runtime if the provided size is wrong.-def flatten_to [n][m] 't (l: i64) (xs: [n][m]t): [l]t =-  flatten xs :> [l]t- -- | Like `flatten`, but on the outer three dimensions of an array.-def flatten_3d [n][m][l] 't (xs: [n][m][l]t): []t =+def flatten_3d [n][m][l] 't (xs: [n][m][l]t): [n*m*l]t =   flatten (flatten xs)  -- | Like `flatten`, but on the outer four dimensions of an array.-def flatten_4d [n][m][l][k] 't (xs: [n][m][l][k]t): []t =+def flatten_4d [n][m][l][k] 't (xs: [n][m][l][k]t): [n*m*l*k]t =   flatten (flatten_3d xs)  -- | Splits the outer dimension of an array in two. -- -- **Complexity:** O(1).-def unflatten [p] 't (n: i64) (m: i64) (xs: [p]t): [n][m]t =-  intrinsics.unflatten n m xs :> [n][m]t+def unflatten 't [n][m] (xs: [n*m]t): [n][m]t =+  intrinsics.unflatten n m xs  -- | Like `unflatten`, but produces three dimensions.-def unflatten_3d [p] 't (n: i64) (m: i64) (l: i64) (xs: [p]t): [n][m][l]t =-  unflatten n m (unflatten (n*m) l xs)+def unflatten_3d 't [n][m][l] (xs: [n*m*l]t): [n][m][l]t =+  unflatten (unflatten xs)  -- | Like `unflatten`, but produces four dimensions.-def unflatten_4d [p] 't (n: i64) (m: i64) (l: i64) (k: i64) (xs: [p]t): [n][m][l][k]t =-  unflatten n m (unflatten_3d (n*m) l k xs)+def unflatten_4d 't [n][m][l][k] (xs: [n*m*l*k]t): [n][m][l][k]t =+  unflatten (unflatten_3d xs)  -- | Transpose an array. --

@@ -178,7 +178,7 @@ -- **Work:** *O(n ✕ W(p))* -- -- **Span:** *O(log(n) ✕ W(p))*-def partition [n] 'a (p: a -> bool) (as: [n]a): ([]a, []a) =+def partition [n] 'a (p: a -> bool) (as: [n]a): ?[k].([k]a, [n-k]a) =   let p' x = if p x then 0 else 1   let (as', is) = intrinsics.partition 2 p' as   in (as'[0:is[0]], as'[is[0]:n])@@ -188,10 +188,12 @@ -- **Work:** *O(n ✕ (W(p1) + W(p2)))* -- -- **Span:** *O(log(n) ✕ (W(p1) + W(p2)))*-def partition2 [n] 'a (p1: a -> bool) (p2: a -> bool) (as: [n]a): ([]a, []a, []a) =+def partition2 [n] 'a (p1: a -> bool) (p2: a -> bool) (as: [n]a): ?[k][l].([k]a, [l]a, [n-k-l]a) =   let p' x = if p1 x then 0 else if p2 x then 1 else 2   let (as', is) = intrinsics.partition 3 p' as-  in (as'[0:is[0]], as'[is[0]:is[0]+is[1]], as'[is[0]+is[1]:n])+  in (as'[0:is[0]],+      as'[is[0]:is[0]+is[1]] :> [is[1]]a,+      as'[is[0]+is[1]:n] :> [n-is[0]-is[1]]a)  -- | Return `true` if the given function returns `true` for all -- elements in the array.

@@ -226,9 +226,6 @@       arr_tan <- tangent arr       arrs_tans <- mapM tangent arrs       addStm $ Let pat_tan aux $ BasicOp $ Concat d (arr_tan :| arrs_tans) w-    Copy arr -> do-      arr_tan <- tangent arr-      addStm $ Let pat_tan aux $ BasicOp $ Copy arr_tan     Manifest ds arr -> do       arr_tan <- tangent arr       addStm $ Let pat_tan aux $ BasicOp $ Manifest ds arr_tan@@ -245,9 +242,6 @@     Rearrange perm arr -> do       arr_tan <- tangent arr       addStm $ Let pat_tan aux $ BasicOp $ Rearrange perm arr_tan-    Rotate rots arr -> do-      arr_tan <- tangent arr-      addStm $ Let pat_tan aux $ BasicOp $ Rotate rots arr_tan     _ -> error $ "basicFwd: Unsupported op " ++ prettyString op  fwdLambda :: Lambda SOACS -> ADM (Lambda SOACS)

@@ -141,14 +141,9 @@           updateAdj arr <=< letExp "adj_rearrange" . BasicOp $             Rearrange (rearrangeInverse perm) pat_adj     ---    Rotate rots arr -> do+    Replicate (Shape []) (Var se) -> do       (_pat_v, pat_adj) <- commonBasicOp pat aux e m-      returnSweepCode $ do-        let neg = BasicOp . BinOp (Sub Int64 OverflowWrap) (intConst Int64 0)-        rots' <- mapM (letSubExp "rot_neg" . neg) rots-        void $-          updateAdj arr <=< letExp "adj_rotate" . BasicOp $-            Rotate rots' pat_adj+      returnSweepCode $ void $ updateAdj se pat_adj     --     Replicate (Shape ns) x -> do       (_pat_v, pat_adj) <- commonBasicOp pat aux e m@@ -184,10 +179,6 @@          zipWithM_ updateAdj (arr : arrs) slices     ---    Copy se -> do-      (_pat_v, pat_adj) <- commonBasicOp pat aux e m-      returnSweepCode $ void $ updateAdj se pat_adj-    --     Manifest _ se -> do       (_pat_v, pat_adj) <- commonBasicOp pat aux e m       returnSweepCode $ void $ updateAdj se pat_adj@@ -211,7 +202,9 @@         t <- lookupType v_adj         v_adj_copy <-           case t of-            Array {} -> letExp "update_val_adj_copy" $ BasicOp $ Copy v_adj+            Array {} ->+              letExp "update_val_adj_copy" . BasicOp $+                Replicate mempty (Var v_adj)             _ -> pure v_adj         updateSubExpAdj v v_adj_copy         zeroes <- letSubExp "update_zero" . zeroExp =<< subExpType v

@@ -183,7 +183,9 @@   dst_type <- lookupType dst   let dst_dims = arrayDims dst_type -  dst_cpy <- letExp (baseString dst <> "_copy") $ BasicOp $ Copy dst+  dst_cpy <-+    letExp (baseString dst <> "_copy") . BasicOp $+      Replicate mempty (Var dst)    acc_v_p <- newParam "acc_v" $ Prim t   acc_i_p <- newParam "acc_i" $ Prim int64@@ -492,7 +494,9 @@ diffAddHist _ops x aux n add ne is vs w rf dst m = do   let t = paramDec $ head $ lambdaParams add -  dst_cpy <- letExp (baseString dst <> "_copy") $ BasicOp $ Copy dst+  dst_cpy <-+    letExp (baseString dst <> "_copy") . BasicOp $+      Replicate mempty (Var dst)    f <- mkIdentityLambda [Prim int64, t]   auxing aux . letBindNames [x] . Op $

@@ -318,7 +318,8 @@               v' <- letExp "restore" $ BasicOp $ Index vs $ fullSlice vs_t [DimFix i_i64']               t <- lookupType v               v'' <- case (t, v `elem` consumed) of-                (Array {}, True) -> letExp "restore_copy" $ BasicOp $ Copy v'+                (Array {}, True) ->+                  letExp "restore_copy" $ BasicOp $ Replicate mempty $ Var v'                 _ -> pure v'               pure $ Just (v, v'')       | otherwise = pure Nothing

@@ -254,7 +254,9 @@             v_t <- lookupType v             case v_t of               Array {} -> do-                v' <- letExp (baseString v <> "_ad_copy") (BasicOp $ Copy v)+                v' <-+                  letExp (baseString v <> "_ad_copy") . BasicOp $+                    Replicate mempty (Var v)                 addSubstitution v' v                 pure [(v, v')]               _ -> pure mempty@@ -269,7 +271,11 @@       v_t <- lookupType v       case v_t of         Acc {} -> error $ "copyConsumedArrsInBody: Acc " <> prettyString v-        Array {} -> M.singleton v <$> letExp (baseString v <> "_ad_copy") (BasicOp $ Copy v)+        Array {} ->+          M.singleton v+            <$> letExp+              (baseString v <> "_ad_copy")+              (BasicOp $ Replicate mempty (Var v))         _ -> pure mempty  returnSweepCode :: ADM a -> ADM a

@@ -27,9 +27,6 @@       slice = fullSlice arr_t [DimSlice start w stride]   letExp (baseString arr <> "_rev") $ BasicOp $ Index arr slice -eRotate :: MonadBuilder m => [SubExp] -> VName -> m VName-eRotate rots arr = letExp (baseString arr <> "_rot") $ BasicOp $ Rotate rots arr- scanExc ::   (MonadBuilder m, Rep m ~ SOACS) =>   String ->@@ -40,34 +37,27 @@   w <- arraysSize 0 <$> mapM lookupType arrs   form <- scanSOAC [scan]   res_incl <- letTupExp (desc <> "_incl") $ Op $ Screma w arrs form-  res_incl_rot <- mapM (eRotate [intConst Int64 (-1)]) res_incl    iota <-     letExp "iota" . BasicOp $       Iota w (intConst Int64 0) (intConst Int64 1) Int64    iparam <- newParam "iota_param" $ Prim int64-  vparams <- mapM (newParam "vp") ts-  let params = iparam : vparams -  body <- runBodyBuilder . localScope (scopeOfLParams params) $ do+  lam <- mkLambda [iparam] $ do     let first_elem =           eCmpOp             (CmpEq int64)             (eSubExp (Var (paramName iparam)))             (eSubExp (intConst Int64 0))-    eBody-      [ eIf-          first_elem-          (resultBodyM nes)-          (resultBodyM $ map (Var . paramName) vparams)-      ]+        prev = toExp $ le64 (paramName iparam) - 1+    fmap subExpsRes . letTupExp' "scan_ex_res"+      =<< eIf+        first_elem+        (resultBodyM $ scanNeutral scan)+        (eBody $ map (`eIndex` prev) res_incl) -  let lam = Lambda params body ts-  letTupExp desc $ Op $ Screma w (iota : res_incl_rot) (mapSOAC lam)-  where-    nes = scanNeutral scan-    ts = lambdaReturnType $ scanLambda scan+  letTupExp desc $ Op $ Screma w [iota] (mapSOAC lam)  mkF :: Lambda SOACS -> ADM ([VName], Lambda SOACS) mkF lam = do

@@ -100,7 +100,9 @@   -- of the program.  In that case the asymptotics will not be   -- (locally) preserved, but since ys must necessarily have been   -- constructed somewhere close, they are probably globally OK.-  ys_copy <- letExp (baseString ys <> "_copy") $ BasicOp $ Copy ys+  ys_copy <-+    letExp (baseString ys <> "_copy") . BasicOp $+      Replicate mempty (Var ys)   returnSweepCode $ do     ys_adj <- lookupAdjVal ys     -- computing vs_ctrbs and updating vs_adj

@@ -27,7 +27,7 @@ import Futhark.Analysis.PrimExp import Futhark.Analysis.PrimExp.Convert import Futhark.IR.Prop.Names-import Futhark.IR.Syntax.Core+import Futhark.IR.Syntax.Core (SubExp (..), VName) import Futhark.Util import Futhark.Util.Pretty import Prelude hiding (negate)

@@ -134,14 +134,12 @@ basicOpMetrics FlatIndex {} = seen "FlatIndex" basicOpMetrics FlatUpdate {} = seen "FlatUpdate" basicOpMetrics Concat {} = seen "Concat"-basicOpMetrics Copy {} = seen "Copy" basicOpMetrics Manifest {} = seen "Manifest" basicOpMetrics Iota {} = seen "Iota" basicOpMetrics Replicate {} = seen "Replicate" basicOpMetrics Scratch {} = seen "Scratch" basicOpMetrics Reshape {} = seen "Reshape" basicOpMetrics Rearrange {} = seen "Rearrange"-basicOpMetrics Rotate {} = seen "Rotate" basicOpMetrics UpdateAcc {} = seen "UpdateAcc"  -- | Compute metrics for this lambda.

@@ -47,7 +47,7 @@   toExp (FunExp h args t) =     Apply (nameFromString h)       <$> args'-      <*> pure [primRetType t]+      <*> pure [(primRetType t, mempty)]       <*> pure (Safe, mempty, [])     where       args' = zip <$> mapM (toSubExp "apply_arg") args <*> pure (repeat Observe)@@ -78,7 +78,7 @@   primExpFromSubExpM f se primExpFromExp f (Apply fname args ts _)   | isBuiltInFunction fname,-    [Prim t] <- map declExtTypeOf ts =+    [Prim t] <- map (declExtTypeOf . fst) ts =       FunExp (nameToString fname) <$> mapM (primExpFromSubExpM f . fst) args <*> pure t primExpFromExp _ _ = fail "Not a PrimExp" 

@@ -353,9 +353,10 @@   | length ds == length is,     Just (Prim t) <- lookupSubExpType v table =       Just $ Indexed mempty $ primExpFromSubExp t v-indexExp table (BasicOp (Replicate (Shape [_]) (Var v))) _ (_ : is) = do+indexExp table (BasicOp (Replicate s (Var v))) _ is = do   guard $ v `available` table-  index' v is table+  guard $ s /= mempty+  index' v (drop (shapeRank s) is) table indexExp table (BasicOp (Reshape _ newshape v)) _ is   | Just oldshape <- arrayDims <$> lookupType v table =       -- TODO: handle coercions more efficiently.

@@ -26,8 +26,10 @@ import Futhark.IR.TypeCheck (Checkable, checkProg) import Futhark.Internalise.Defunctionalise as Defunctionalise import Futhark.Internalise.Defunctorise as Defunctorise+import Futhark.Internalise.FullNormalise as FullNormalise import Futhark.Internalise.LiftLambdas as LiftLambdas import Futhark.Internalise.Monomorphise as Monomorphise+import Futhark.Internalise.ReplaceRecords as ReplaceRecords import Futhark.Optimise.ArrayShortCircuiting qualified as ArrayShortCircuiting import Futhark.Optimise.CSE import Futhark.Optimise.DoubleBuffer@@ -74,11 +76,13 @@     Pipeline [UntypedPass]   | -- | Partially evaluate away the module language.     Defunctorise-  | -- | Defunctorise and monomorphise.+  | -- | Defunctorise and normalise.+    FullNormalise+  | -- | Defunctorise, normalise and monomorphise.     Monomorphise-  | -- | Defunctorise, monomorphise, and lambda-lift.+  | -- | Defunctorise, normalise, monomorphise and lambda-lift.     LiftLambdas-  | -- | Defunctorise, monomorphise, lambda-lift, and defunctionalise.+  | -- | Defunctorise, normalise, monomorphise, lambda-lift and defunctionalise.     Defunctionalise  data Config = Config@@ -540,6 +544,11 @@       "Partially evaluate all module constructs and print the residual program.",     Option       []+      ["normalise"]+      (NoArg $ Right $ \opts -> opts {futharkPipeline = FullNormalise})+      "Fully normalise the program.",+    Option+      []       ["monomorphise"]       (NoArg $ Right $ \opts -> opts {futharkPipeline = Monomorphise})       "Monomorphise the program.",@@ -732,12 +741,20 @@         Defunctorise -> do           (_, imports, src) <- readProgram'           liftIO $ p $ evalState (Defunctorise.transformProg imports) src+        FullNormalise -> do+          (_, imports, src) <- readProgram'+          liftIO $+            p $+              flip evalState src $+                Defunctorise.transformProg imports+                  >>= FullNormalise.transformProg         Monomorphise -> do           (_, imports, src) <- readProgram'           liftIO $             p $               flip evalState src $                 Defunctorise.transformProg imports+                  >>= FullNormalise.transformProg                   >>= Monomorphise.transformProg         LiftLambdas -> do           (_, imports, src) <- readProgram'@@ -745,7 +762,9 @@             p $               flip evalState src $                 Defunctorise.transformProg imports+                  >>= FullNormalise.transformProg                   >>= Monomorphise.transformProg+                  >>= ReplaceRecords.transformProg                   >>= LiftLambdas.transformProg         Defunctionalise -> do           (_, imports, src) <- readProgram'@@ -753,7 +772,9 @@             p $               flip evalState src $                 Defunctorise.transformProg imports+                  >>= FullNormalise.transformProg                   >>= Monomorphise.transformProg+                  >>= ReplaceRecords.transformProg                   >>= LiftLambdas.transformProg                   >>= Defunctionalise.transformProg         Pipeline {} -> do

@@ -8,12 +8,13 @@ import Control.Monad.State import Data.FileEmbed import Data.List (nubBy)-import Data.Text.Lazy qualified as T-import Data.Text.Lazy.IO qualified as T+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Text.Lazy qualified as LT import Futhark.Compiler (Imports, dumpError, fileProg, newFutharkConfig, readProgramFiles) import Futhark.Doc.Generator import Futhark.Pipeline (FutharkM, Verbosity (..), runFutharkM)-import Futhark.Util (directoryContents, trim)+import Futhark.Util (directoryContents) import Futhark.Util.Options import Language.Futhark.Semantic (mkInitialImport) import Language.Futhark.Syntax (DocComment (..), progDoc)@@ -65,7 +66,7 @@       (file_htmls, _warnings) =         renderFiles direct_imports $           filter (not . ignored) imports-  mapM_ (write . fmap renderHtml) file_htmls+  mapM_ (write . fmap (LT.toStrict . renderHtml)) file_htmls   write ("style.css", cssFile)   where     write :: (FilePath, T.Text) -> IO ()@@ -82,7 +83,7 @@     -- recognise them by a file comment containing "ignore".     ignored (_, fm) =       case progDoc (fileProg fm) of-        Just (DocComment s _) -> trim s == "ignore"+        Just (DocComment s _) -> T.strip s == "ignore"         _ -> False  cssFile :: T.Text

@@ -14,6 +14,7 @@ import Futhark.Pipeline import Futhark.Util.Options import Futhark.Util.Pretty+import Language.Futhark import Language.Futhark.Interpreter qualified as I import Language.Futhark.Parser import Language.Futhark.Semantic qualified as T@@ -53,7 +54,13 @@     (_, Left terr) -> do       hPutDoc stderr $ I.prettyTypeError terr       exitWith $ ExitFailure 1-    (_, Right (_, e)) -> pure e+    (_, Right ([], e)) -> pure e+    (_, Right (tparams, e)) -> do+      putDocLn $ "Inferred type of expression: " <> align (pretty (typeOf e))+      T.putStrLn $+        "The following types are ambiguous: "+          <> T.intercalate ", " (map (nameToText . toName . typeParamName) tparams)+      exitWith $ ExitFailure 1   pval <- runInterpreterNoBreak $ I.interpretExp ctx fexp   case pval of     Left err -> do

@@ -7,13 +7,13 @@ import Data.IORef (newIORef) import Futhark.LSP.Handlers (handlers) import Futhark.LSP.State (emptyState)-import Language.LSP.Server-import Language.LSP.Types+import Language.LSP.Protocol.Types   ( SaveOptions (SaveOptions),-    TextDocumentSyncKind (TdSyncIncremental),+    TextDocumentSyncKind (TextDocumentSyncKind_Incremental),     TextDocumentSyncOptions (..),     type (|?) (InR),   )+import Language.LSP.Server  -- | Run @futhark lsp@ main :: String -> [String] -> IO ()@@ -29,7 +29,7 @@           interpretHandler = \env -> Iso (runLspT env) liftIO,           options =             defaultOptions-              { textDocumentSync = Just syncOptions+              { optTextDocumentSync = Just syncOptions               }         }   pure ()@@ -38,7 +38,7 @@ syncOptions =   TextDocumentSyncOptions     { _openClose = Just True,-      _change = Just TdSyncIncremental,+      _change = Just TextDocumentSyncKind_Incremental,       _willSave = Just False,       _willSaveWaitUntil = Just False,       _save = Just $ InR $ SaveOptions $ Just False

@@ -690,14 +690,12 @@   exists <- liftIO $ doesFileExist fname   liftIO $ createDirectoryIfMissing True $ envImgDir env   when (exists && scriptVerbose (envOpts env) > 0) $-    liftIO $-      T.hPutStrLn stderr $-        "Using existing file: " <> T.pack fname+    liftIO . T.hPutStrLn stderr $+      "Using existing file: " <> T.pack fname   unless exists $ do     when (scriptVerbose (envOpts env) > 0) $-      liftIO $-        T.hPutStrLn stderr $-          "Generating new file: " <> T.pack fname+      liftIO . T.hPutStrLn stderr $+        "Generating new file: " <> T.pack fname     m fname   modify $ \s -> s {stateFiles = S.insert fname $ stateFiles s}   pure (fname, fname_rel)@@ -848,8 +846,8 @@     (progressStep, progressDone)       | fancyTerminal,         scriptVerbose (envOpts env) > 0 =-          ( \j num_frames -> do-              liftIO . T.putStr $+          ( \j num_frames -> liftIO $ do+              T.putStr $                 "\r"                   <> progressBar                     (ProgressBar 40 (fromIntegral num_frames - 1) (fromIntegral j))@@ -858,9 +856,8 @@                   <> "/"                   <> prettyText num_frames                   <> " "-              liftIO $ hFlush stdout,-            liftIO $ do-              T.putStrLn ""+              hFlush stdout,+            liftIO $ T.putStrLn ""           )       | otherwise =           (\_ _ -> pure (), pure ())

@@ -79,7 +79,7 @@       ("lsp", (LSP.main, "Run LSP server.")),       ("thanks", (Misc.mainThanks, "Express gratitude.")),       ("tokens", (Misc.mainTokens, "Print tokens from Futhark file.")),-      ("benchcmp", (Benchcmp.main, "Compare two Futhark benchmarks."))+      ("benchcmp", (Benchcmp.main, "Compare two benchmark results."))     ]  msg :: String

@@ -502,7 +502,7 @@     ( "unbreak",       ( unbreakCommand,         [text|-Skip all future occurences of the current breakpoint.+Skip all future occurrences of the current breakpoint. |]       )     ),

@@ -23,7 +23,7 @@ import Futhark.Test import Futhark.Util (atMostChars, fancyTerminal, showText) import Futhark.Util.Options-import Futhark.Util.Pretty (annotate, bold, hardline, pretty, putDoc, vsep)+import Futhark.Util.Pretty (annotate, bgColor, bold, hardline, pretty, putDoc, vsep) import Futhark.Util.Table import System.Console.ANSI (clearFromCursorToScreenEnd, clearLine, cursorUpLine) import System.Console.Terminal.Size qualified as Terminal@@ -107,6 +107,8 @@     TypeCheck   | -- | Only compile (do not run).     Compile+  | -- | Only internalise (do not run).+    Internalise   | -- | Test compiled code.     Compiled   | -- | Test interpreted code.@@ -247,7 +249,7 @@           ]   case testAction testcase of     CompileTimeFailure expected_error ->-      context checkctx $ do+      unless (mode == Internalise) . context checkctx $ do         (code, _, err) <-           liftIO $ readProcessWithExitCode futhark ["check", program] ""         case code of@@ -255,15 +257,23 @@           ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark           ExitFailure 1 -> throwError $ T.decodeUtf8 err           ExitFailure _ -> liftExcept $ checkError expected_error $ T.decodeUtf8 err-    RunCases {} | mode == TypeCheck -> do-      let options = ["check", program] ++ configExtraCompilerOptions progs-      context checkctx $ do-        (code, _, err) <- liftIO $ readProcessWithExitCode futhark options ""--        case code of-          ExitSuccess -> pure ()-          ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark-          ExitFailure _ -> throwError $ T.decodeUtf8 err+    RunCases {}+      | mode == TypeCheck -> do+          let options = ["check", program] ++ configExtraCompilerOptions progs+          context checkctx $ do+            (code, _, err) <- liftIO $ readProcessWithExitCode futhark options ""+            case code of+              ExitSuccess -> pure ()+              ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark+              ExitFailure _ -> throwError $ T.decodeUtf8 err+      | mode == Internalise -> do+          let options = ["dev", program] ++ configExtraCompilerOptions progs+          context checkctx $ do+            (code, _, err) <- liftIO $ readProcessWithExitCode futhark options ""+            case code of+              ExitSuccess -> pure ()+              ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark+              ExitFailure _ -> throwError $ T.decodeUtf8 err     RunCases ios structures warnings -> do       -- Compile up-front and reuse same executable for several entry points.       let backend = configBackend progs@@ -567,7 +577,7 @@                     when fancy moveCursorToTableTop                     clear                     putDoc $-                      annotate bold (pretty (testCaseProgram test) <> ":")+                      annotate (bold <> bgColor Red) (pretty (testCaseProgram test) <> ":")                         <> hardline                         <> vsep (map pretty s)                         <> hardline@@ -694,12 +704,17 @@       "c"       ["compiled"]       (NoArg $ Right $ \config -> config {configTestMode = Compiled})-      "Only run compiled code",+      "Only run compiled code (the default)",     Option       "C"       ["compile"]       (NoArg $ Right $ \config -> config {configTestMode = Compile})       "Only compile, do not run.",+    Option+      "I"+      ["internalise"]+      (NoArg $ Right $ \config -> config {configTestMode = Internalise})+      "Only run the compiler frontend.",     Option       []       ["no-terminal", "notty"]

@@ -174,14 +174,15 @@     return ret;   } +  long long new_usage = ctx->$id:usagename + size;   if (ctx->detail_memory) {     fprintf(ctx->log, "Allocating %lld bytes for %s in %s (then allocated: %lld bytes)",             (long long) size,             desc, $string:spacedesc,-            (long long) ctx->$id:usagename + size);+            new_usage);   }-  if (ctx->$id:usagename > ctx->$id:peakname) {-    ctx->$id:peakname = ctx->$id:usagename;+  if (new_usage > ctx->$id:peakname) {+    ctx->$id:peakname = new_usage;     if (ctx->detail_memory) {       fprintf(ctx->log, " (new peak).\n");     }@@ -196,7 +197,7 @@     *(block->references) = 1;     block->size = size;     block->desc = desc;-    ctx->$id:usagename += size;+    ctx->$id:usagename = new_usage;     return FUTHARK_SUCCESS;   } else {     // We are naively assuming that any memory allocation error is due to OOM.

@@ -415,7 +415,7 @@          in ( storageSize pt rank shape',               storeValueHeader sign pt rank shape' [C.cexp|out|]                 ++ [C.cstms|ret |= $id:values_array(ctx, obj->$id:field, (void*)out);-                            out += $exp:num_elems * $int:(primByteSize pt::Int);|]+                            out += $exp:num_elems * sizeof($ty:(primStorageType pt));|]             )    ctx_ty <- contextType@@ -452,7 +452,7 @@         stms $ loadValueHeader sign pt rank [C.cexp|$id:shapearr|] [C.cexp|src|]         item [C.citem|const void* $id:dataptr = src;|]         stm [C.cstm|obj->$id:field = NULL;|]-        stm [C.cstm|src += $exp:num_elems * $int:(primByteSize pt::Int);|]+        stm [C.cstm|src += $exp:num_elems * sizeof($ty:(primStorageType pt));|]         pure           [C.cstms|              obj->$id:field = $id:new_array(ctx, $id:dataptr, $args:dims);

@@ -1115,7 +1115,7 @@       Var "np.nan"   | otherwise = simpleCall "np.float64" [Float $ fromRational $ toRational v] compilePrimValue (BoolValue v) = Bool v-compilePrimValue UnitValue = Var "None"+compilePrimValue UnitValue = Var "np.byte(0)"  compileVar :: VName -> CompilerM op s PyExp compileVar v = asks $ fromMaybe (Var v') . M.lookup v' . envVarExp

@@ -386,7 +386,7 @@     Call       (Var "cl.array.Array")       [ Arg $ Var "self.queue",-        Arg $ Tuple dims',+        Arg $ Tuple $ dims' <> [Integer 0 | bt == Imp.Unit],         Arg $ Var $ Py.compilePrimToExtNp bt ept,         ArgKeyword "data" mem'       ]

@@ -251,11 +251,10 @@ storageSize pt rank shape =   [C.cexp|$int:header_size +           $int:rank * sizeof(typename int64_t) +-          $exp:(cproduct dims) * $int:pt_size|]+          $exp:(cproduct dims) * sizeof($ty:(primStorageType pt))|]   where-    header_size, pt_size :: Int+    header_size :: Int     header_size = 1 + 1 + 1 + 4 -- 'b' <version> <num_dims> <type>-    pt_size = primByteSize pt     dims = [[C.cexp|$exp:shape[$int:i]|] | i <- [0 .. rank - 1]]  typeStr :: Signedness -> PrimType -> String

@@ -90,7 +90,6 @@     dPrimVE,     dIndexSpace,     dIndexSpace',-    rotateIndex,     sFor,     sWhile,     sComment,@@ -684,7 +683,7 @@       Just (x, y, z) -> (Just x, Just y, Just z)     compile = do       (inparams, arrayds, args) <- compileInParams types params params_entry-      (results, outparams, dests) <- compileOutParams types rettype ret_entry+      (results, outparams, dests) <- compileOutParams types (map fst rettype) ret_entry       addFParams params       addArrays arrayds @@ -937,6 +936,8 @@     slice' = fmap pe64 slice defCompileBasicOp (Pat [pe]) (Replicate shape se)   | Acc {} <- patElemType pe = pure ()+  | shape == mempty =+      copyDWIM (patElemName pe) [] se []   | otherwise =       sLoopNest shape $ \is -> copyDWIMFix (patElemName pe) is se [] defCompileBasicOp _ Scratch {} =@@ -951,8 +952,6 @@         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) [] defCompileBasicOp (Pat [pe]) (Manifest _ src) =   copyDWIM (patElemName pe) [] (Var src) [] defCompileBasicOp (Pat [pe]) (Concat i (x :| ys) _) = do@@ -988,13 +987,6 @@     isLiteral _ = Nothing defCompileBasicOp _ Rearrange {} =   pure ()-defCompileBasicOp (Pat [pe]) (Rotate rs arr) = do-  shape <- arrayShape <$> lookupType arr-  sLoopNest shape $ \is -> do-    is' <- sequence $ zipWith3 rotate (shapeDims shape) rs is-    copyDWIMFix (patElemName pe) is (Var arr) is'-  where-    rotate d r i = dPrimVE "rot_i" $ rotateIndex (pe64 d) (pe64 r) i defCompileBasicOp _ Reshape {} =   pure () defCompileBasicOp _ (UpdateAcc acc is vs) = sComment "UpdateAcc" $ do@@ -1755,13 +1747,6 @@    in foldl1 (.&&.) $ zipWith condInBounds slice dims  --- Building blocks for constructing code.--rotateIndex ::-  Imp.TExp Int64 ->-  Imp.TExp Int64 ->-  Imp.TExp Int64 ->-  Imp.TExp Int64-rotateIndex d r i = (i + r) `mod` d  sFor' :: VName -> Imp.Exp -> ImpM rep r op () -> ImpM rep r op () sFor' i bound body = do

@@ -235,10 +235,6 @@   | Acc {} <- patElemType pe = pure ()   | otherwise =       sReplicate (patElemName pe) se-expCompiler (Pat [pe]) (BasicOp (Rotate rs arr))-  | Acc {} <- patElemType pe = pure ()-  | otherwise =-      sRotateKernel (patElemName pe) (map pe64 rs) arr -- Allocation in the "local" space is just a placeholder. expCompiler _ (Op (Alloc _ (Space "local"))) =   pure ()@@ -309,7 +305,15 @@  mapTransposeFunction :: PrimType -> Imp.Function Imp.HostOp mapTransposeFunction bt =-  Imp.Function Nothing [] params transpose_code+  Imp.Function Nothing [] params $+    Imp.DebugPrint ("\n# Transpose " <> prettyString bt) Nothing+      <> Imp.DebugPrint "Number of arrays  " (Just $ untyped $ Imp.le64 num_arrays)+      <> Imp.DebugPrint "X elements        " (Just $ untyped $ Imp.le64 x)+      <> Imp.DebugPrint "Y elements        " (Just $ untyped $ Imp.le64 y)+      <> Imp.DebugPrint "Source      offset" (Just $ untyped $ Imp.le64 srcoffset)+      <> Imp.DebugPrint "Destination offset" (Just $ untyped $ Imp.le64 destoffset)+      <> transpose_code+      <> Imp.DebugPrint "" Nothing   where     params =       [ memparam destmem,@@ -323,7 +327,7 @@      space = Space "device"     memparam v = Imp.MemParam v space-    intparam v = Imp.ScalarParam v $ IntType Int32+    intparam v = Imp.ScalarParam v $ IntType Int64      [ destmem,       destoffset,@@ -334,7 +338,8 @@       y,       mulx,       muly,-      block+      block,+      use_32b       ] =         zipWith           (VName . nameFromString)@@ -349,7 +354,8 @@             -- transpose kernels             "mulx",             "muly",-            "block"+            "block",+            "use_32b"           ]           [0 ..] @@ -361,18 +367,23 @@     -- When an input array has either width==1 or height==1, performing a     -- transpose will be the same as performing a copy.     can_use_copy =-      let onearr = Imp.le32 num_arrays .==. 1-          height_is_one = Imp.le32 y .==. 1-          width_is_one = Imp.le32 x .==. 1+      let onearr = Imp.le64 num_arrays .==. 1+          height_is_one = Imp.le64 y .==. 1+          width_is_one = Imp.le64 x .==. 1        in onearr .&&. (width_is_one .||. height_is_one)      transpose_code =       Imp.If input_is_empty mempty $         mconcat-          [ Imp.DeclareScalar muly Imp.Nonvolatile (IntType Int32),-            Imp.SetScalar muly $ untyped $ block_dim `quot` Imp.le32 x,-            Imp.DeclareScalar mulx Imp.Nonvolatile (IntType Int32),-            Imp.SetScalar mulx $ untyped $ block_dim `quot` Imp.le32 y,+          [ Imp.DeclareScalar muly Imp.Nonvolatile (IntType Int64),+            Imp.SetScalar muly $ untyped $ block_dim `quot` Imp.le64 x,+            Imp.DeclareScalar mulx Imp.Nonvolatile (IntType Int64),+            Imp.SetScalar mulx $ untyped $ block_dim `quot` Imp.le64 y,+            Imp.DeclareScalar use_32b Imp.Nonvolatile Bool,+            Imp.SetScalar use_32b $+              untyped $+                (le64 destoffset + le64 num_arrays * le64 x * le64 y) .<=. 2 ^ (31 :: Int) - 1+                  .&&. (le64 srcoffset + le64 num_arrays * le64 x * le64 y) .<=. 2 ^ (31 :: Int) - 1,             Imp.If can_use_copy copy_code $               Imp.If should_use_lowwidth (callTransposeKernel TransposeLowWidth) $                 Imp.If should_use_lowheight (callTransposeKernel TransposeLowHeight) $@@ -381,47 +392,91 @@           ]      input_is_empty =-      Imp.le32 num_arrays .==. 0 .||. Imp.le32 x .==. 0 .||. Imp.le32 y .==. 0+      Imp.le64 num_arrays .==. 0 .||. Imp.le64 x .==. 0 .||. Imp.le64 y .==. 0      should_use_small =-      Imp.le32 x .<=. (block_dim `quot` 2)-        .&&. Imp.le32 y .<=. (block_dim `quot` 2)+      Imp.le64 x .<=. (block_dim `quot` 2)+        .&&. Imp.le64 y .<=. (block_dim `quot` 2)      should_use_lowwidth =-      Imp.le32 x .<=. (block_dim `quot` 2)-        .&&. block_dim .<. Imp.le32 y+      Imp.le64 x .<=. (block_dim `quot` 2)+        .&&. block_dim .<. Imp.le64 y      should_use_lowheight =-      Imp.le32 y .<=. (block_dim `quot` 2)-        .&&. block_dim .<. Imp.le32 x+      Imp.le64 y .<=. (block_dim `quot` 2)+        .&&. block_dim .<. Imp.le64 x      copy_code =-      let num_bytes = sExt64 $ Imp.le32 x * Imp.le32 y * primByteSize bt+      let num_bytes = sExt64 $ Imp.le64 x * Imp.le64 y * primByteSize bt        in Imp.Copy             bt             destmem-            (Imp.Count $ sExt64 $ Imp.le32 destoffset)+            (Imp.Count $ Imp.le64 destoffset)             space             srcmem-            (Imp.Count $ sExt64 $ Imp.le32 srcoffset)+            (Imp.Count $ Imp.le64 srcoffset)             space             (Imp.Count num_bytes) -    callTransposeKernel =+    callTransposeKernel which =+      Imp.If+        (isBool (LeafExp use_32b Bool))+        ( Imp.DebugPrint "Using 32-bit indexing" Nothing+            <> callTransposeKernel32 which+        )+        ( Imp.DebugPrint "Using 64-bit indexing" Nothing+            <> callTransposeKernel64 which+        )++    callTransposeKernel64 =       Imp.Op         . Imp.CallKernel         . mapTransposeKernel+          (int64, le64)           (mapTransposeName bt)           block_dim_int           ( destmem,-            Imp.le32 destoffset,+            le64 destoffset,             srcmem,-            Imp.le32 srcoffset,-            Imp.le32 x,-            Imp.le32 y,-            Imp.le32 mulx,-            Imp.le32 muly,-            Imp.le32 num_arrays,+            le64 srcoffset,+            le64 x,+            le64 y,+            le64 mulx,+            le64 muly,+            le64 num_arrays,             block           )           bt++    callTransposeKernel32 =+      Imp.Op+        . Imp.CallKernel+        . mapTransposeKernel+          (int32, le32)+          (mapTransposeName bt)+          block_dim_int+          ( destmem,+            sExt32 (le64 destoffset),+            srcmem,+            sExt32 (le64 srcoffset),+            sExt32 (le64 x),+            sExt32 (le64 y),+            sExt32 (le64 mulx),+            sExt32 (le64 muly),+            sExt32 (le64 num_arrays),+            block+          )+          bt++-- Note [32-bit transpositions]+--+-- Transposition kernels are much slower when they have to use 64-bit+-- arithmetic.  I observed about 0.67x slowdown on an A100 GPU when+-- transposing four-byte elements (much less when transposing 8-byte+-- elements).  Unfortunately, 64-bit arithmetic is a requirement for+-- large arrays (see #1953 for what happens otherwise).  We generate+-- both 32- and 64-bit index arithmetic versions of transpositions,+-- and dynamically pick between them at runtime.  This is an+-- unfortunate code bloat, and it would be preferable if we could+-- simply optimise the 64-bit version to make this distinction+-- unnecessary.  Fortunately these kernels are quite small.

@@ -34,7 +34,6 @@     -- * Host-level bulk operations     sReplicate,     sIota,-    sRotateKernel,     sCopy,      -- * Atomics@@ -1397,28 +1396,6 @@         tmp <- tvVar <$> dPrim "tmp" pt         emit $ Imp.Read tmp srcmem srcidx pt srcspace Imp.Nonvolatile         emit $ Imp.Write destmem destidx pt destspace Imp.Nonvolatile $ Imp.var tmp pt---- | Perform a Rotate with a kernel.-sRotateKernel :: VName -> [Imp.TExp Int64] -> VName -> CallKernelGen ()-sRotateKernel dest rs src = do-  t <- lookupType src-  let ds = map pe64 $ arrayDims t-  n <- dPrimVE "rotate_n" $ product ds-  (virtualise, constants) <- simpleKernelConstants n "rotate"--  fname <- askFunction-  let name =-        keyWithEntryPoint fname $-          nameFromString $-            "rotate_" ++ show (baseTag $ kernelGlobalThreadIdVar constants)--  sKernelFailureTolerant True threadOperations constants name $-    virtualise $ \gtid -> sWhen (gtid .<. n) $ do-      is' <- dIndexSpace' "rep_i" ds gtid-      is'' <- sequence $ zipWith3 rotate ds rs is'-      copyDWIMFix dest is' (Var src) is''-  where-    rotate d r i = dPrimVE "rot_i" $ rotateIndex d r i  compileThreadResult ::   SegSpace ->

@@ -286,7 +286,7 @@   ltid <- kernelLocalThreadId . kernelConstants <$> askEnv   sWhen (ltid .==. 0) $ updateAcc acc is vs   sOp $ Imp.Barrier Imp.FenceLocal-compileGroupExp (Pat [dest]) (BasicOp (Replicate ds se)) = do+compileGroupExp (Pat [dest]) (BasicOp (Replicate ds se)) | ds /= mempty = do   flat <- newVName "rep_flat"   is <- replicateM (arrayRank dest_t) (newVName "rep_i")   let is' = map le64 is@@ -295,14 +295,6 @@   sOp $ Imp.Barrier Imp.FenceLocal   where     dest_t = patElemType dest-compileGroupExp (Pat [dest]) (BasicOp (Rotate rs arr)) = do-  ds <- map pe64 . arrayDims <$> lookupType arr-  groupCoverSpace ds $ \is -> do-    is' <- sequence $ zipWith3 rotate ds rs is-    copyDWIMFix (patElemName dest) is (Var arr) is'-  sOp $ Imp.Barrier Imp.FenceLocal-  where-    rotate d r i = dPrimVE "rot_i" $ rotateIndex d (pe64 r) i compileGroupExp (Pat [dest]) (BasicOp (Iota n e s it)) = do   n' <- toExp n   e' <- toExp e@@ -695,8 +687,6 @@     onStm (Let (Pat [pe]) _ (BasicOp (Replicate {}))) =       S.singleton $ arrayDims $ patElemType pe     onStm (Let (Pat [pe]) _ (BasicOp (Iota {}))) =-      S.singleton $ arrayDims $ patElemType pe-    onStm (Let (Pat [pe]) _ (BasicOp (Copy {}))) =       S.singleton $ arrayDims $ patElemType pe     onStm (Let (Pat [pe]) _ (BasicOp (Manifest {}))) =       S.singleton $ arrayDims $ patElemType pe

@@ -7,8 +7,9 @@   ) where +-- See also Note [32-bit transpositions].+ import Futhark.CodeGen.ImpCode.GPU-import Futhark.IR.Prop.Types import Futhark.Util.IntegralExp (divUp, quot, rem) import Prelude hiding (quot, rem) @@ -23,98 +24,98 @@   deriving (Eq, Ord, Show)  -- | The types of the arguments accepted by a transposition function.-type TransposeArgs =+type TransposeArgs int =   ( VName,-    TExp Int32,+    TExp int,     VName,-    TExp Int32,-    TExp Int32,-    TExp Int32,-    TExp Int32,-    TExp Int32,-    TExp Int32,+    TExp int,+    TExp int,+    TExp int,+    TExp int,+    TExp int,+    TExp int,     VName   ) -elemsPerThread :: TExp Int32-elemsPerThread = 4+elemsPerThread :: Num a => a+elemsPerThread = 8 -mapTranspose :: TExp Int32 -> TransposeArgs -> PrimType -> TransposeType -> KernelCode-mapTranspose block_dim args t kind =+mapTranspose :: forall int. IntExp int => (PrimType, VName -> TExp int) -> TExp int -> TransposeArgs int -> PrimType -> TransposeType -> KernelCode+mapTranspose (int, le) block_dim args t kind =   case kind of     TransposeSmall ->       mconcat         [ get_ids,-          dec our_array_offset $ le32 get_global_id_0 `quot` (height * width) * (height * width),-          dec x_index $ (le32 get_global_id_0 `rem` (height * width)) `quot` height,-          dec y_index $ le32 get_global_id_0 `rem` height,+          dec our_array_offset $ le get_global_id_0 `quot` (height * width) * (height * width),+          dec x_index $ (le get_global_id_0 `rem` (height * width)) `quot` height,+          dec y_index $ le get_global_id_0 `rem` height,           DeclareScalar val Nonvolatile t,           dec odata_offset $-            (basic_odata_offset `quot` primByteSize t) + le32 our_array_offset,+            (basic_odata_offset `quot` primByteSize t) + le our_array_offset,           dec idata_offset $-            (basic_idata_offset `quot` primByteSize t) + le32 our_array_offset,-          dec index_in $ le32 y_index * width + le32 x_index,-          dec index_out $ le32 x_index * height + le32 y_index,+            (basic_idata_offset `quot` primByteSize t) + le our_array_offset,+          dec index_in $ le y_index * width + le x_index,+          dec index_out $ le x_index * height + le y_index,           when-            (le32 get_global_id_0 .<. width * height * num_arrays)+            (le get_global_id_0 .<. width * height * num_arrays)             ( mconcat-                [ Read val idata (elements $ sExt64 $ le32 idata_offset + le32 index_in) t (Space "global") Nonvolatile,-                  Write odata (elements $ sExt64 $ le32 odata_offset + le32 index_out) t (Space "global") Nonvolatile (var val t)+                [ Read val idata (elements $ toOffset $ le idata_offset + le index_in) t (Space "global") Nonvolatile,+                  Write odata (elements $ toOffset $ le odata_offset + le index_out) t (Space "global") Nonvolatile (var val t)                 ]             )         ]     TransposeLowWidth ->       mkTranspose $         lowDimBody-          (le32 get_group_id_0 * block_dim + (le32 get_local_id_0 `quot` muly))-          ( le32 get_group_id_1 * block_dim * muly-              + le32 get_local_id_1-              + (le32 get_local_id_0 `rem` muly) * block_dim+          (le get_group_id_0 * block_dim + (le get_local_id_0 `quot` muly))+          ( le get_group_id_1 * block_dim * muly+              + le get_local_id_1+              + (le get_local_id_0 `rem` muly) * block_dim           )-          ( le32 get_group_id_1 * block_dim * muly-              + le32 get_local_id_0-              + (le32 get_local_id_1 `rem` muly) * block_dim+          ( le get_group_id_1 * block_dim * muly+              + le get_local_id_0+              + (le get_local_id_1 `rem` muly) * block_dim           )-          (le32 get_group_id_0 * block_dim + (le32 get_local_id_1 `quot` muly))+          (le get_group_id_0 * block_dim + (le get_local_id_1 `quot` muly))     TransposeLowHeight ->       mkTranspose $         lowDimBody-          ( le32 get_group_id_0 * block_dim * mulx-              + le32 get_local_id_0-              + (le32 get_local_id_1 `rem` mulx) * block_dim+          ( le get_group_id_0 * block_dim * mulx+              + le get_local_id_0+              + (le get_local_id_1 `rem` mulx) * block_dim           )-          (le32 get_group_id_1 * block_dim + (le32 get_local_id_1 `quot` mulx))-          (le32 get_group_id_1 * block_dim + (le32 get_local_id_0 `quot` mulx))-          ( le32 get_group_id_0 * block_dim * mulx-              + le32 get_local_id_1-              + (le32 get_local_id_0 `rem` mulx) * block_dim+          (le get_group_id_1 * block_dim + (le get_local_id_1 `quot` mulx))+          (le get_group_id_1 * block_dim + (le get_local_id_0 `quot` mulx))+          ( le get_group_id_0 * block_dim * mulx+              + le get_local_id_1+              + (le get_local_id_0 `rem` mulx) * block_dim           )     TransposeNormal ->       mkTranspose $         mconcat-          [ dec x_index $ le32 get_global_id_0,-            dec y_index $ le32 get_group_id_1 * tile_dim + le32 get_local_id_1,+          [ dec x_index $ le get_global_id_0,+            dec y_index $ le get_group_id_1 * tile_dim + le get_local_id_1,             DeclareScalar val Nonvolatile t,-            when (le32 x_index .<. width) $-              For j (untyped elemsPerThread) $-                let i = le32 j * (tile_dim `quot` elemsPerThread)+            when (le x_index .<. width) $+              For j (untyped (elemsPerThread :: TExp int)) $+                let i = le j * (tile_dim `quot` elemsPerThread)                  in mconcat-                      [ dec index_in $ (le32 y_index + i) * width + le32 x_index,-                        when (le32 y_index + i .<. height) $+                      [ dec index_in $ (le y_index + i) * width + le x_index,+                        when (le y_index + i .<. height) $                           mconcat                             [ Read                                 val                                 idata-                                (elements $ sExt64 $ le32 idata_offset + le32 index_in)+                                (elements $ toOffset $ le idata_offset + le index_in)                                 t                                 (Space "global")                                 Nonvolatile,                               Write                                 block                                 ( elements $-                                    sExt64 $-                                      (le32 get_local_id_1 + i) * (tile_dim + 1)-                                        + le32 get_local_id_0+                                    toOffset $+                                      (le get_local_id_1 + i) * (tile_dim + 1)+                                        + le get_local_id_0                                 )                                 t                                 (Space "local")@@ -123,27 +124,27 @@                             ]                       ],             Op $ Barrier FenceLocal,-            SetScalar x_index $ untyped $ le32 get_group_id_1 * tile_dim + le32 get_local_id_0,-            SetScalar y_index $ untyped $ le32 get_group_id_0 * tile_dim + le32 get_local_id_1,-            when (le32 x_index .<. height) $-              For j (untyped elemsPerThread) $-                let i = le32 j * (tile_dim `quot` elemsPerThread)+            SetScalar x_index $ untyped $ le get_group_id_1 * tile_dim + le get_local_id_0,+            SetScalar y_index $ untyped $ le get_group_id_0 * tile_dim + le get_local_id_1,+            when (le x_index .<. height) $+              For j (untyped (elemsPerThread :: TExp int)) $+                let i = le j * (tile_dim `quot` elemsPerThread)                  in mconcat-                      [ dec index_out $ (le32 y_index + i) * height + le32 x_index,-                        when (le32 y_index + i .<. width) $+                      [ dec index_out $ (le y_index + i) * height + le x_index,+                        when (le y_index + i .<. width) $                           mconcat                             [ Read                                 val                                 block-                                ( elements . sExt64 $-                                    le32 get_local_id_0 * (tile_dim + 1) + le32 get_local_id_1 + i+                                ( elements . toOffset $+                                    le get_local_id_0 * (tile_dim + 1) + le get_local_id_1 + i                                 )                                 t                                 (Space "local")                                 Nonvolatile,                               Write                                 odata-                                (elements $ sExt64 $ le32 odata_offset + le32 index_out)+                                (elements $ toOffset $ le odata_offset + le index_out)                                 t                                 (Space "global")                                 Nonvolatile@@ -152,6 +153,9 @@                       ]           ]   where+    toOffset :: TExp int -> TExp Int64+    toOffset = sExt64+     dec v (TPrimExp e) =       DeclareScalar v Nonvolatile (primExpType e) <> SetScalar v e     tile_dim = 2 * block_dim@@ -216,30 +220,30 @@      get_ids =       mconcat-        [ DeclareScalar get_local_id_0 Nonvolatile int32,+        [ DeclareScalar get_local_id_0 Nonvolatile int,           Op $ GetLocalId get_local_id_0 0,-          DeclareScalar get_local_id_1 Nonvolatile int32,+          DeclareScalar get_local_id_1 Nonvolatile int,           Op $ GetLocalId get_local_id_1 1,-          DeclareScalar get_group_id_0 Nonvolatile int32,+          DeclareScalar get_group_id_0 Nonvolatile int,           Op $ GetGroupId get_group_id_0 0,-          DeclareScalar get_group_id_1 Nonvolatile int32,+          DeclareScalar get_group_id_1 Nonvolatile int,           Op $ GetGroupId get_group_id_1 1,-          DeclareScalar get_group_id_2 Nonvolatile int32,+          DeclareScalar get_group_id_2 Nonvolatile int,           Op $ GetGroupId get_group_id_2 2,-          DeclareScalar get_local_size_0 Nonvolatile int32,+          DeclareScalar get_local_size_0 Nonvolatile int,           Op $ GetLocalSize get_local_size_0 0,-          DeclareScalar get_global_id_0 Nonvolatile int32,-          SetScalar get_global_id_0 $ untyped $ le32 get_group_id_0 * le32 get_local_size_0 + le32 get_local_id_0+          DeclareScalar get_global_id_0 Nonvolatile int,+          SetScalar get_global_id_0 $ untyped $ le get_group_id_0 * le get_local_size_0 + le get_local_id_0         ]      mkTranspose body =       mconcat         [ get_ids,-          dec our_array_offset $ le32 get_group_id_2 * width * height,+          dec our_array_offset $ le get_group_id_2 * width * height,           dec odata_offset $-            (basic_odata_offset `quot` primByteSize t) + le32 our_array_offset,+            (basic_odata_offset `quot` primByteSize t) + le our_array_offset,           dec idata_offset $-            (basic_idata_offset `quot` primByteSize t) + le32 our_array_offset,+            (basic_idata_offset `quot` primByteSize t) + le our_array_offset,           body         ] @@ -248,19 +252,19 @@         [ dec x_index x_in_index,           dec y_index y_in_index,           DeclareScalar val Nonvolatile t,-          dec index_in $ le32 y_index * width + le32 x_index,-          when (le32 x_index .<. width .&&. le32 y_index .<. height) $+          dec index_in $ le y_index * width + le x_index,+          when (le x_index .<. width .&&. le y_index .<. height) $             mconcat               [ Read                   val                   idata-                  (elements $ sExt64 $ le32 idata_offset + le32 index_in)+                  (elements $ sExt64 $ le idata_offset + le index_in)                   t                   (Space "global")                   Nonvolatile,                 Write                   block-                  (elements $ sExt64 $ le32 get_local_id_1 * (block_dim + 1) + le32 get_local_id_0)+                  (elements $ sExt64 $ le get_local_id_1 * (block_dim + 1) + le get_local_id_0)                   t                   (Space "local")                   Nonvolatile@@ -269,19 +273,19 @@           Op $ Barrier FenceLocal,           SetScalar x_index $ untyped x_out_index,           SetScalar y_index $ untyped y_out_index,-          dec index_out $ le32 y_index * height + le32 x_index,-          when (le32 x_index .<. height .&&. le32 y_index .<. width) $+          dec index_out $ le y_index * height + le x_index,+          when (le x_index .<. height .&&. le y_index .<. width) $             mconcat               [ Read                   val                   block-                  (elements $ sExt64 $ le32 get_local_id_0 * (block_dim + 1) + le32 get_local_id_1)+                  (elements $ toOffset $ le get_local_id_0 * (block_dim + 1) + le get_local_id_1)                   t                   (Space "local")                   Nonvolatile,                 Write                   odata-                  (elements $ sExt64 (le32 odata_offset + le32 index_out))+                  (elements $ toOffset (le odata_offset + le index_out))                   t                   (Space "global")                   Nonvolatile@@ -289,6 +293,21 @@               ]         ] +lowDimKernelAndGroupSize ::+  IntExp int =>+  TExp int ->+  TExp int ->+  TExp int ->+  TExp int ->+  ([TExp int], [TExp int])+lowDimKernelAndGroupSize block_dim num_arrays x_elems y_elems =+  ( [ x_elems `divUp` block_dim,+      y_elems `divUp` block_dim,+      num_arrays+    ],+    [block_dim, block_dim, 1]+  )+ -- | Generate a transpose kernel.  There is special support to handle -- input arrays with low width, low height, or both. --@@ -313,38 +332,41 @@ -- an additional element prevents bank conflicts from occuring when -- the tile is accessed column-wise. mapTransposeKernel ::+  forall int.+  IntExp int =>+  (PrimType, VName -> TExp int) ->   String ->   Integer ->-  TransposeArgs ->+  TransposeArgs int ->   PrimType ->   TransposeType ->   Kernel-mapTransposeKernel desc block_dim_int args t kind =+mapTransposeKernel (int, le) desc block_dim_int args t kind =   Kernel     { kernelBody =         DeclareMem block (Space "local")           <> Op (LocalAlloc block block_size)-          <> mapTranspose block_dim args t kind,+          <> mapTranspose (int, le) block_dim args t kind,       kernelUses = uses,       kernelNumGroups = map untyped num_groups,       kernelGroupSize = map (Left . untyped) group_size,-      kernelName = nameFromString name,+      kernelName = nameFromString (name <> "_" <> prettyString int),       kernelFailureTolerant = True,       kernelCheckLocalMemory = False     }   where     pad2DBytes k = k * (k + 1) * primByteSize t+    block_size :: Count Bytes (TExp Int64)     block_size =       bytes $         case kind of-          TransposeSmall -> 1 :: TExp Int64-          -- Not used, but AMD's OpenCL-          -- does not like zero-size-          -- local memory.+          TransposeSmall -> 1+          -- Not used, but AMD's OpenCL does not like zero-size local+          -- memory.           TransposeNormal -> fromInteger $ pad2DBytes $ 2 * block_dim_int           TransposeLowWidth -> fromInteger $ pad2DBytes block_dim_int           TransposeLowHeight -> fromInteger $ pad2DBytes block_dim_int-    block_dim = fromInteger block_dim_int :: TExp Int32+    block_dim = fromInteger block_dim_int :: TExp int      ( odata,       basic_odata_offset,@@ -379,7 +401,7 @@      uses =       map-        (`ScalarUse` int32)+        (`ScalarUse` IntType Int64)         ( namesToList $             mconcat $               map@@ -401,17 +423,3 @@         TransposeLowHeight -> desc ++ "_low_height"         TransposeLowWidth -> desc ++ "_low_width"         TransposeNormal -> desc--lowDimKernelAndGroupSize ::-  TExp Int32 ->-  TExp Int32 ->-  TExp Int32 ->-  TExp Int32 ->-  ([TExp Int32], [TExp Int32])-lowDimKernelAndGroupSize block_dim num_arrays x_elems y_elems =-  ( [ x_elems `divUp` block_dim,-      y_elems `divUp` block_dim,-      num_arrays-    ],-    [block_dim, block_dim, 1]-  )

@@ -348,12 +348,12 @@     _ ->       error $ "eSignum: operand " ++ prettyString e ++ " has invalid type." --- | Construct a 'Copy' expression.+-- | Copy a value. eCopy ::   MonadBuilder m =>   m (Exp (Rep m)) ->   m (Exp (Rep m))-eCopy e = BasicOp . Copy <$> (letExp "copy_arg" =<< e)+eCopy e = BasicOp . Replicate mempty <$> (letSubExp "copy_arg" =<< e)  -- | Construct a body from expressions.  If multiple expressions are -- provided, their results will be concatenated in order and returned

@@ -6,6 +6,7 @@ import Control.Monad import Control.Monad.Reader import Control.Monad.Writer (Writer, WriterT, runWriter, runWriterT, tell)+import Data.Bifunctor (second) import Data.Char (isAlpha, isSpace, toUpper) import Data.List (find, groupBy, inits, intersperse, isPrefixOf, partition, sort, sortOn, tails) import Data.Map qualified as M@@ -20,7 +21,7 @@ import Language.Futhark import Language.Futhark.Semantic import Language.Futhark.TypeChecker.Monad hiding (warn)-import System.FilePath (makeRelative, splitPath, (-<.>), (<.>), (</>))+import System.FilePath (makeRelative, splitPath, (-<.>), (</>)) import Text.Blaze.Html5 (AttributeValue, Html, toHtml, (!)) import Text.Blaze.Html5 qualified as H import Text.Blaze.Html5.Attributes qualified as A@@ -180,7 +181,7 @@   where     file_map = vnameToFileMap imports     importHtml import_name =-      "doc" </> makeRelative "/" (fromString (includeToString import_name)) <.> "html"+      "doc" </> makeRelative "/" (fromString (includeToString import_name)) -<.> "html"  -- | The header documentation (which need not be present) can contain -- an abstract and further sections.@@ -188,10 +189,10 @@ headerDoc prog =   case progDoc prog of     Just (DocComment doc loc) -> do-      let (abstract, more_sections) = splitHeaderDoc doc+      let (abstract, more_sections) = splitHeaderDoc $ T.unpack doc       first_paragraph <- docHtml $ Just $ DocComment (firstParagraph abstract) loc-      abstract' <- docHtml $ Just $ DocComment abstract loc-      more_sections' <- docHtml $ Just $ DocComment more_sections loc+      abstract' <- docHtml $ Just $ DocComment (T.pack abstract) loc+      more_sections' <- docHtml $ Just $ DocComment (T.pack more_sections) loc       pure         ( first_paragraph,           selfLink "abstract" (H.h2 "Abstract") <> abstract',@@ -203,7 +204,7 @@       fromMaybe (s, mempty) $         find (("\n##" `isPrefixOf`) . snd) $           zip (inits s) (tails s)-    firstParagraph = unlines . takeWhile (not . paragraphSeparator) . lines+    firstParagraph = T.pack . unlines . takeWhile (not . paragraphSeparator) . lines     paragraphSeparator = all isSpace  contentsPage :: [ImportName] -> [(ImportName, Html)] -> Html@@ -398,8 +399,10 @@   Just $ parens <$> me' synopsisOpened (ModImport _ (Info file) _) = Just $ do   current <- asks ctxCurrent-  let dest = fromString $ relativise (includeToFilePath file) current <> ".html"-  pure $ keyword "import " <> (H.a ! A.href dest) (fromString $ show file)+  let dest = fromString $ relativise (includeToFilePath file) current -<.> "html"+  pure $+    keyword "import "+      <> (H.a ! A.href dest) (fromString (show (includeToString file))) synopsisOpened (ModAscript _ se _ _) = Just $ do   se' <- synopsisSigExp se   pure $ "... : " <> se'@@ -415,9 +418,7 @@ valBindHtml name (ValBind _ _ retdecl (Info rettype) tparams params _ _ _ _) = do   let tparams' = mconcat $ map ((" " <>) . typeParamHtml) tparams       noLink' =-        noLink $-          map typeParamName tparams-            ++ map identName (S.toList $ mconcat $ map patIdents params)+        noLink $ map typeParamName tparams <> foldMap patNames params   rettype' <- noLink' $ maybe (retTypeHtml rettype) typeExpHtml retdecl   params' <- noLink' $ mapM paramHtml params   pure@@ -479,13 +480,13 @@  renderTypeBind :: (VName, TypeBinding) -> DocM Html renderTypeBind (name, TypeAbbr l tps tp) = do-  tp' <- retTypeHtml tp+  tp' <- retTypeHtml $ toResRet Nonunique tp   pure $ H.div $ typeAbbrevHtml l (vnameHtml name) tps <> " = " <> tp'  synopsisValBindBind :: (VName, BoundV) -> DocM Html synopsisValBindBind (name, BoundV tps t) = do   let tps' = map typeParamHtml tps-  t' <- typeHtml t+  t' <- typeHtml $ second (const Nonunique) t   pure $     keyword "val "       <> vnameHtml name@@ -497,11 +498,11 @@ dietHtml Consume = "*" dietHtml Observe = "" -typeHtml :: StructType -> DocM Html+typeHtml :: TypeBase Size Uniqueness -> DocM Html typeHtml t = case t of-  Array _ u shape et -> do+  Array u shape et -> do     shape' <- prettyShape shape-    et' <- typeHtml $ Scalar et+    et' <- typeHtml $ Scalar $ second (const Nonunique) et     pure $ prettyU u <> shape' <> et'   Scalar (Prim et) -> pure $ primTypeHtml et   Scalar (Record fs)@@ -513,12 +514,12 @@       ppField (name, tp) = do         tp' <- typeHtml tp         pure $ toHtml (nameToString name) <> ": " <> tp'-  Scalar (TypeVar _ u et targs) -> do+  Scalar (TypeVar u et targs) -> do     targs' <- mapM typeArgHtml targs     et' <- qualNameHtml et     pure $ prettyU u <> et' <> mconcat (map (" " <>) targs')   Scalar (Arrow _ pname d t1 t2) -> do-    t1' <- typeHtml t1+    t1' <- typeHtml $ second (const Nonunique) t1     t2' <- retTypeHtml t2     pure $ case pname of       Named v ->@@ -530,7 +531,7 @@       ppClause (n, ts) = joinBy " " . (ppConstr n :) <$> mapM typeHtml ts       ppConstr name = "#" <> toHtml (nameToString name) -retTypeHtml :: StructRetType -> DocM Html+retTypeHtml :: ResRetType -> DocM Html retTypeHtml (RetType [] t) = typeHtml t retTypeHtml (RetType dims t) = do   t' <- typeHtml t@@ -541,8 +542,8 @@   mconcat <$> mapM dimDeclHtml ds  typeArgHtml :: TypeArg Size -> DocM Html-typeArgHtml (TypeArgDim d _) = dimDeclHtml d-typeArgHtml (TypeArgType t _) = typeHtml t+typeArgHtml (TypeArgDim d) = dimDeclHtml d+typeArgHtml (TypeArgType t) = typeHtml $ second (const Nonunique) t  modParamHtml :: [ModParamBase Info VName] -> DocM Html modParamHtml [] = pure mempty@@ -691,24 +692,22 @@ vnameLink' (VName _ tag) current file =   if file == current     then "#" ++ show tag-    else relativise file current ++ ".html#" ++ show tag+    else relativise file current -<.> ".html#" ++ show tag -paramHtml :: Pat -> DocM Html+paramHtml :: Pat ParamType -> DocM Html paramHtml pat = do   let (pat_param, d, t) = patternParam pat-  t' <- typeHtml t+  t' <- typeHtml $ second (const Nonunique) t   pure $ case pat_param of     Named v -> parens (vnameHtml v <> ": " <> dietHtml d <> t')     Unnamed -> t'  relativise :: FilePath -> FilePath -> FilePath relativise dest src =-  concat (replicate (length (splitPath src) - 1) "../") ++ dest+  concat (replicate (length (splitPath src) - 1) "../") ++ makeRelative "/" dest  dimDeclHtml :: Size -> DocM Html-dimDeclHtml (NamedSize v) = brackets <$> qualNameHtml v-dimDeclHtml (ConstSize n) = pure $ brackets $ toHtml (show n)-dimDeclHtml AnySize {} = pure $ brackets mempty+dimDeclHtml = pure . brackets . toHtml . prettyString  dimExpHtml :: SizeExp Info VName -> DocM Html dimExpHtml (SizeExpAny _) = pure $ brackets mempty@@ -735,7 +734,7 @@   H.preEscapedText     . GFM.commonmarkToHtml [] [GFM.extAutolink]     . T.pack-    <$> identifierLinks loc doc+    <$> identifierLinks loc (T.unpack doc) docHtml Nothing = pure mempty  identifierLinks :: SrcLoc -> String -> DocM String

@@ -44,6 +44,10 @@   opReturns (SegOp op) = segOpReturns op   opReturns k = extReturns <$> opType k +instance OpReturns (HostOp NoOp (Aliases GPUMem)) where+  opReturns (SegOp op) = segOpReturns op+  opReturns k = extReturns <$> opType k+ instance OpReturns (HostOp NoOp (Engine.Wise GPUMem)) where   opReturns (SegOp op) = segOpReturns op   opReturns k = extReturns <$> opType k

@@ -14,6 +14,7 @@ where  import Futhark.Analysis.PrimExp.Convert+import Futhark.IR.Aliases (Aliases) import Futhark.IR.MC.Op import Futhark.IR.Mem import Futhark.IR.Mem.Simplify@@ -37,6 +38,10 @@   expTypesFromPat = pure . map snd . bodyReturnsFromPat  instance OpReturns (MCOp NoOp MCMem) where+  opReturns (ParOp _ op) = segOpReturns op+  opReturns (OtherOp NoOp) = pure []++instance OpReturns (MCOp NoOp (Aliases MCMem)) where   opReturns (ParOp _ op) = segOpReturns op   opReturns (OtherOp NoOp) = pure [] 

@@ -279,6 +279,9 @@   declExtTypeOf (MemArray pt shape u _) = Array pt shape u   declExtTypeOf (MemAcc acc ispace ts u) = Acc acc ispace ts u +instance FixExt ret => ExtTyped (MemInfo ExtSize Uniqueness ret) where+  extTypeOf = fromDecl . declExtTypeOf+ instance FixExt ret => ExtTyped (MemInfo ExtSize NoUniqueness ret) where   extTypeOf (MemPrim pt) = Prim pt   extTypeOf (MemMem space) = Mem space@@ -1070,7 +1073,7 @@     isMergeVar v = find ((== v) . paramName . snd) $ zip [0 ..] mergevars     mergevars = map fst merge expReturns (Apply _ _ ret _) =-  pure $ map funReturnsToExpReturns ret+  pure $ map (funReturnsToExpReturns . fst) ret expReturns (Match _ _ _ (MatchDec ret _)) =   pure $ map bodyReturnsToExpReturns ret expReturns (Op op) =

@@ -44,116 +44,35 @@ import Control.Monad import Control.Monad.State import Data.Function (on, (&))-import Data.List (elemIndex, partition, sort, sortBy, zip4, zipWith4)+import Data.List (sort, sortBy, zip4, zipWith4) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as M-import Data.Maybe (fromJust, isJust, isNothing)+import Data.Maybe (isJust) import Data.Traversable-import Futhark.Analysis.AlgSimplify qualified as AlgSimplify import Futhark.Analysis.PrimExp import Futhark.Analysis.PrimExp.Convert-import Futhark.IR.Mem.Interval+import Futhark.IR.Mem.LMAD import Futhark.IR.Prop import Futhark.IR.Syntax   ( DimIndex (..),     FlatDimIndex (..),     FlatSlice (..),     Slice (..),-    Type,     dimFix,     flatSliceDims,     flatSliceStrides,     unitSlice,   )-import Futhark.IR.Syntax.Core (Ext (..), VName (..))+import Futhark.IR.Syntax.Core (Ext (..)) import Futhark.Transform.Rename import Futhark.Transform.Substitute-import Futhark.Util import Futhark.Util.IntegralExp import Futhark.Util.Pretty import Prelude hiding (gcd, id, mod, (.)) --- | The shape of an index function.-type Shape num = [num]- type Indices num = [num] -type Permutation = [Int]---- | The physical element ordering alongside a dimension, i.e. the--- sign of the stride.-data Monotonicity-  = -- | Increasing.-    Inc-  | -- | Decreasing.-    Dec-  | -- | Unknown.-    Unknown-  deriving (Show, Eq)---- | A single dimension in an 'LMAD'.-data LMADDim num = LMADDim-  { ldStride :: num,-    ldShape :: num,-    ldPerm :: Int,-    ldMon :: Monotonicity-  }-  deriving (Show, Eq)--instance Ord Monotonicity where-  (<=) _ Inc = True-  (<=) Unknown _ = True-  (<=) _ Unknown = False-  (<=) Inc Dec = False-  (<=) _ Dec = True--instance Ord num => Ord (LMADDim num) where-  (LMADDim s1 q1 p1 m1) <= (LMADDim s2 q2 p2 m2) =-    ([q1, s1] < [q2, s2])-      || ( ([q1, s1] == [q2, s2])-             && ( (p1 < p2)-                    || ( (p1 == p2)-                           && (m1 <= m2)-                       )-                )-         )---- | LMAD's representation consists of a general offset and for each dimension a--- stride, number of elements (or shape), permutation, and--- monotonicity. Note that the permutation is not strictly necessary in that the--- permutation can be performed directly on LMAD dimensions, but then it is--- difficult to extract the permutation back from an LMAD.------ LMAD algebra is closed under composition w.r.t. operators such as--- permute, index and slice.  However, other operations, such as--- reshape, cannot always be represented inside the LMAD algebra.------ It follows that the general representation of an index function is a list of--- LMADS, in which each following LMAD in the list implicitly corresponds to an--- irregular reshaping operation.------ However, we expect that the common case is when the index function is one--- LMAD -- we call this the "nice" representation.------ Finally, the list of LMADs is kept in an @IxFun@ together with the shape of--- the original array, and a bit to indicate whether the index function is--- contiguous, i.e., if we instantiate all the points of the current index--- function, do we get a contiguous memory interval?------ By definition, the LMAD \( \sigma + \{ (n_1, s_1), \ldots, (n_k, s_k) \} \),--- where \(n\) and \(s\) denote the shape and stride of each dimension, denotes--- the set of points:------ \[---    \{ ~ \sigma + i_1 * s_1 + \ldots + i_m * s_m ~ | ~ 0 \leq i_1 < n_1, \ldots, 0 \leq i_m < n_m ~ \}--- \]-data LMAD num = LMAD-  { lmadOffset :: num,-    lmadDims :: [LMADDim num]-  }-  deriving (Show, Eq, Ord)- -- | An index function is a mapping from a multidimensional array -- index space (the domain) to a one-dimensional memory index space. -- Essentially, it explains where the element at position @[i,j,p]@ of@@ -172,21 +91,6 @@   }   deriving (Show, Eq) -instance Pretty Monotonicity where-  pretty = pretty . show--instance Pretty num => Pretty (LMAD num) where-  pretty (LMAD offset dims) =-    braces . semistack $-      [ "offset:" <+> group (pretty offset),-        "strides:" <+> p ldStride,-        "shape:" <+> p ldShape,-        "permutation:" <+> p ldPerm,-        "monotonicity:" <+> p ldMon-      ]-    where-      p f = group $ brackets $ align $ commasep $ map (pretty . f) dims- instance Pretty num => Pretty (IxFun num) where   pretty (IxFun lmads oshp cg) =     braces . semistack $@@ -195,45 +99,21 @@         "LMADs:" <+> brackets (commastack $ NE.toList $ NE.map pretty lmads)       ] -instance Substitute num => Substitute (LMAD num) where-  substituteNames substs = fmap $ substituteNames substs- instance Substitute num => Substitute (IxFun num) where   substituteNames substs = fmap $ substituteNames substs -instance Substitute num => Rename (LMAD num) where-  rename = substituteRename- instance Substitute num => Rename (IxFun num) where   rename = substituteRename -instance FreeIn num => FreeIn (LMAD num) where-  freeIn' = foldMap freeIn'- instance FreeIn num => FreeIn (IxFun num) where   freeIn' = foldMap freeIn' -instance FreeIn num => FreeIn (LMADDim num) where-  freeIn' (LMADDim s n _ _) = freeIn' s <> freeIn' n--instance Functor LMAD where-  fmap = fmapDefault- instance Functor IxFun where   fmap = fmapDefault -instance Foldable LMAD where-  foldMap = foldMapDefault- instance Foldable IxFun where   foldMap = foldMapDefault -instance Traversable LMAD where-  traverse f (LMAD offset dims) =-    LMAD <$> f offset <*> traverse f' dims-    where-      f' (LMADDim s n p m) = LMADDim <$> f s <*> f n <*> pure p <*> pure m- -- It is important that the traversal order here is the same as in -- mkExistential. instance Traversable IxFun where@@ -248,14 +128,6 @@ (@++@) :: NonEmpty a -> NonEmpty a -> NonEmpty a (x :| xs) @++@ (y :| ys) = x :| xs ++ [y] ++ ys -invertMonotonicity :: Monotonicity -> Monotonicity-invertMonotonicity Inc = Dec-invertMonotonicity Dec = Inc-invertMonotonicity Unknown = Unknown--lmadPermutation :: LMAD num -> Permutation-lmadPermutation = map ldPerm . lmadDims- setLMADPermutation :: Permutation -> LMAD num -> LMAD num setLMADPermutation perm lmad =   lmad {lmadDims = zipWith (\dim p -> dim {ldPerm = p}) (lmadDims lmad) perm}@@ -263,29 +135,6 @@ setLMADShape :: Shape num -> LMAD num -> LMAD num setLMADShape shp lmad = lmad {lmadDims = zipWith (\dim s -> dim {ldShape = s}) (lmadDims lmad) shp} --- | Substitute a name with a PrimExp in an LMAD.-substituteInLMAD ::-  Ord a =>-  M.Map a (TPrimExp t a) ->-  LMAD (TPrimExp t a) ->-  LMAD (TPrimExp t a)-substituteInLMAD tab (LMAD offset dims) =-  let offset' = sub offset-      dims' =-        map-          ( \(LMADDim s n p m) ->-              LMADDim-                (sub s)-                (sub n)-                p-                m-          )-          dims-   in LMAD offset' dims'-  where-    tab' = fmap untyped tab-    sub = TPrimExp . substituteInPrimExp tab' . untyped- -- | Substitute a name with a PrimExp in an index function. substituteInIxFun ::   Ord a =>@@ -330,14 +179,6 @@ shape (IxFun (lmad :| _) _ _) =   permuteFwd (lmadPermutation lmad) $ lmadShapeBase lmad --- | Shape of an LMAD.-lmadShape :: (Eq num, IntegralExp num) => LMAD num -> Shape num-lmadShape lmad = permuteInv (lmadPermutation lmad) $ lmadShapeBase lmad---- | Shape of an LMAD, ignoring permutations.-lmadShapeBase :: (Eq num, IntegralExp num) => LMAD num -> Shape num-lmadShapeBase = map ldShape . lmadDims- -- | Compute the flat memory index for a complete set @inds@ of array indices -- and a certain element size @elem_size@. index ::@@ -821,12 +662,6 @@ isLinear :: (Eq num, IntegralExp num) => IxFun num -> Bool isLinear = (== Just 0) . flip linearWithOffset 1 -permuteFwd :: Permutation -> [a] -> [a]-permuteFwd ps elems = map (elems !!) ps--permuteInv :: Permutation -> [a] -> [a]-permuteInv ps elems = map snd $ sortBy (compare `on` fst) $ zip ps elems- flatOneDim ::   (Eq num, IntegralExp num) =>   num ->@@ -836,28 +671,6 @@   | s == 0 = 0   | otherwise = i * s --- | Generalised iota with user-specified offset and rotates.-makeRotIota ::-  IntegralExp num =>-  Monotonicity ->-  -- | Offset-  num ->-  -- | Shape-  [num] ->-  LMAD num-makeRotIota mon off ns-  | mon == Inc || mon == Dec =-      let rk = length ns-          ss0 = reverse $ take rk $ scanl (*) 1 $ reverse ns-          ss =-            if mon == Inc-              then ss0-              else map (* (-1)) ss0-          ps = map fromIntegral [0 .. rk - 1]-          fi = replicate rk mon-       in LMAD off $ zipWith4 LMADDim ss ns ps fi-  | otherwise = error "makeRotIota: requires Inc or Dec"- -- | Check monotonicity of an index function. ixfunMonotonicity ::   (Eq num, IntegralExp num) =>@@ -940,245 +753,3 @@           == lmadOffset lmad2         && map ldStride (lmadDims lmad1)           == map ldStride (lmadDims lmad2)---- | Computes the maximum span of an 'LMAD'. The result is the lowest and--- highest flat values representable by that 'LMAD'.-flatSpan :: LMAD (TPrimExp Int64 VName) -> TPrimExp Int64 VName-flatSpan (LMAD _ dims) =-  foldr-    ( \dim upper ->-        let spn = ldStride dim * (ldShape dim - 1)-         in -- If you've gotten this far, you've already lost-            spn + upper-    )-    0-    dims---- | Conservatively flatten a list of LMAD dimensions------ Since not all LMADs can actually be flattened, we try to overestimate the--- flattened array instead. This means that any "holes" in betwen dimensions--- will get filled out.--- conservativeFlatten :: (IntegralExp e, Ord e, Pretty e) => LMAD e -> LMAD e-conservativeFlatten :: LMAD (TPrimExp Int64 VName) -> Maybe (LMAD (TPrimExp Int64 VName))-conservativeFlatten (LMAD offset []) =-  pure $ LMAD offset [LMADDim 1 1 0 Inc]-conservativeFlatten l@(LMAD _ [_]) =-  pure l-conservativeFlatten l@(LMAD offset dims) = do-  strd <--    foldM-      gcd-      (ldStride $ head dims)-      $ map ldStride dims-  pure $ LMAD offset [LMADDim strd (shp + 1) 0 Unknown]-  where-    shp = flatSpan l---- | Very conservative GCD calculation. Returns 'Nothing' if the result cannot--- be immediately determined. Does not recurse at all.-gcd :: TPrimExp Int64 VName -> TPrimExp Int64 VName -> Maybe (TPrimExp Int64 VName)-gcd x y = gcd' (abs x) (abs y)-  where-    gcd' a b | a == b = Just a-    gcd' 1 _ = Just 1-    gcd' _ 1 = Just 1-    gcd' a 0 = Just a-    gcd' _ _ = Nothing -- gcd' b (a `Futhark.Util.IntegralExp.rem` b)---- | Returns @True@ if the two 'LMAD's could be proven disjoint.------ Uses some best-approximation heuristics to determine disjointness. For two--- 1-dimensional arrays, we can guarantee whether or not they are disjoint, but--- as soon as more than one dimension is involved, things get more--- tricky. Currently, we try to 'conservativelyFlatten' any LMAD with more than--- one dimension.-disjoint :: [(VName, PrimExp VName)] -> Names -> LMAD (TPrimExp Int64 VName) -> LMAD (TPrimExp Int64 VName) -> Bool-disjoint less_thans non_negatives (LMAD offset1 [dim1]) (LMAD offset2 [dim2]) =-  doesNotDivide (gcd (ldStride dim1) (ldStride dim2)) (offset1 - offset2)-    || AlgSimplify.lessThanish-      less_thans-      non_negatives-      (offset2 + (ldShape dim2 - 1) * ldStride dim2)-      offset1-    || AlgSimplify.lessThanish-      less_thans-      non_negatives-      (offset1 + (ldShape dim1 - 1) * ldStride dim1)-      offset2-  where-    doesNotDivide :: Maybe (TPrimExp Int64 VName) -> TPrimExp Int64 VName -> Bool-    doesNotDivide (Just x) y =-      Futhark.Util.IntegralExp.mod y x-        & untyped-        & constFoldPrimExp-        & TPrimExp-        & (.==.) (0 :: TPrimExp Int64 VName)-        & primBool-        & maybe False not-    doesNotDivide _ _ = False-disjoint less_thans non_negatives lmad1 lmad2 =-  case (conservativeFlatten lmad1, conservativeFlatten lmad2) of-    (Just lmad1', Just lmad2') -> disjoint less_thans non_negatives lmad1' lmad2'-    _ -> False--disjoint2 :: scope -> asserts -> [(VName, PrimExp VName)] -> Names -> LMAD (TPrimExp Int64 VName) -> LMAD (TPrimExp Int64 VName) -> Bool-disjoint2 _ _ less_thans non_negatives lmad1 lmad2 =-  let (offset1, interval1) = lmadToIntervals lmad1-      (offset2, interval2) = lmadToIntervals lmad2-      (neg_offset, pos_offset) =-        partition AlgSimplify.negated $-          offset1 `AlgSimplify.sub` offset2-      (interval1', interval2') =-        unzip $-          sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride . fst)) $-            intervalPairs interval1 interval2-   in case ( distributeOffset pos_offset interval1',-             distributeOffset (map AlgSimplify.negate neg_offset) interval2'-           ) of-        (Just interval1'', Just interval2'') ->-          isNothing-            ( selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval1''-            )-            && isNothing-              ( selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval2''-              )-            && not-              ( all-                  (uncurry (intervalOverlap less_thans non_negatives))-                  (zip interval1'' interval2'')-              )-        _ ->-          False--disjoint3 :: M.Map VName Type -> [PrimExp VName] -> [(VName, PrimExp VName)] -> [PrimExp VName] -> LMAD (TPrimExp Int64 VName) -> LMAD (TPrimExp Int64 VName) -> Bool-disjoint3 scope asserts less_thans non_negatives lmad1 lmad2 =-  let (offset1, interval1) = lmadToIntervals lmad1-      (offset2, interval2) = lmadToIntervals lmad2-      interval1' = fixPoint (mergeDims . joinDims) $ sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride)) interval1-      interval2' = fixPoint (mergeDims . joinDims) $ sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride)) interval2-      (interval1'', interval2'') =-        unzip $-          sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride . fst)) $-            intervalPairs interval1' interval2'-   in disjointHelper 4 interval1'' interval2'' $ offset1 `AlgSimplify.sub` offset2-  where-    disjointHelper :: Int -> [Interval] -> [Interval] -> AlgSimplify.SofP -> Bool-    disjointHelper 0 _ _ _ = False-    disjointHelper i is10 is20 offset =-      let (is1, is2) =-            unzip $-              sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride . fst)) $-                intervalPairs is10 is20-          (neg_offset, pos_offset) = partition AlgSimplify.negated offset-       in case ( distributeOffset pos_offset is1,-                 distributeOffset (map AlgSimplify.negate neg_offset) is2-               ) of-            (Just is1', Just is2') -> do-              let overlap1 = selfOverlap scope asserts less_thans non_negatives is1'-              let overlap2 = selfOverlap scope asserts less_thans non_negatives is2'-              case (overlap1, overlap2) of-                (Nothing, Nothing) ->-                  case namesFromList <$> mapM justLeafExp non_negatives of-                    Just non_negatives' ->-                      not $-                        all-                          (uncurry (intervalOverlap less_thans non_negatives'))-                          (zip is1 is2)-                    _ -> False-                (Just overlapping_dim, _) ->-                  let expanded_offset = AlgSimplify.simplifySofP' <$> expandOffset offset is1-                      splits = splitDim overlapping_dim is1'-                   in all (\(new_offset, new_is1) -> disjointHelper (i - 1) (joinDims new_is1) (joinDims is2') new_offset) splits-                        || maybe False (disjointHelper (i - 1) is1 is2) expanded_offset-                (_, Just overlapping_dim) ->-                  let expanded_offset = AlgSimplify.simplifySofP' <$> expandOffset offset is2-                      splits = splitDim overlapping_dim is2'-                   in all-                        ( \(new_offset, new_is2) ->-                            disjointHelper (i - 1) (joinDims is1') (joinDims new_is2) $-                              map AlgSimplify.negate new_offset-                        )-                        splits-                        || maybe False (disjointHelper (i - 1) is1 is2) expanded_offset-            _ -> False--joinDims :: [Interval] -> [Interval]-joinDims = helper []-  where-    helper acc [] = reverse acc-    helper acc [x] = reverse $ x : acc-    helper acc (x : y : rest) =-      if stride x == stride y && lowerBound x == 0 && lowerBound y == 0-        then helper acc $ x {numElements = numElements x * numElements y} : rest-        else helper (x : acc) (y : rest)--mergeDims :: [Interval] -> [Interval]-mergeDims = helper [] . reverse-  where-    helper acc [] = acc-    helper acc [x] = x : acc-    helper acc (x : y : rest) =-      if stride x * numElements x == stride y && lowerBound x == 0 && lowerBound y == 0-        then helper acc $ x {numElements = numElements x * numElements y} : rest-        else helper (x : acc) (y : rest)--splitDim :: Interval -> [Interval] -> [(AlgSimplify.SofP, [Interval])]-splitDim overlapping_dim0 is-  | [st] <- AlgSimplify.simplify0 $ untyped $ stride overlapping_dim0,-    [st1] <- AlgSimplify.simplify0 $ untyped $ stride overlapping_dim,-    [spn] <- AlgSimplify.simplify0 $ untyped $ stride overlapping_dim * numElements overlapping_dim,-    lowerBound overlapping_dim == 0,-    Just big_dim_elems <- AlgSimplify.maybeDivide spn st,-    Just small_dim_elems <- AlgSimplify.maybeDivide st st1 =-      [ ( [],-          init before-            <> [ Interval 0 (isInt64 $ AlgSimplify.prodToExp big_dim_elems) (stride overlapping_dim0),-                 Interval 0 (isInt64 $ AlgSimplify.prodToExp small_dim_elems) (stride overlapping_dim)-               ]-            <> after-        )-      ]-  | otherwise =-      let shrunk_dim = overlapping_dim {numElements = numElements overlapping_dim - 1}-          point_offset = AlgSimplify.simplify0 $ untyped $ (numElements overlapping_dim - 1 + lowerBound overlapping_dim) * stride overlapping_dim-       in [ (point_offset, before <> after),-            ([], before <> [shrunk_dim] <> after)-          ]-  where-    (before, overlapping_dim, after) =-      fromJust $-        elemIndex overlapping_dim0 is-          >>= (flip focusNth is . (+ 1))--lmadToIntervals :: LMAD (TPrimExp Int64 VName) -> (AlgSimplify.SofP, [Interval])-lmadToIntervals (LMAD offset []) = (AlgSimplify.simplify0 $ untyped offset, [Interval 0 1 1])-lmadToIntervals lmad@(LMAD offset dims0) =-  (offset', map helper $ permuteInv (lmadPermutation lmad) dims0)-  where-    offset' = AlgSimplify.simplify0 $ untyped offset--    helper :: LMADDim (TPrimExp Int64 VName) -> Interval-    helper (LMADDim strd shp _ _) = do-      Interval 0 (AlgSimplify.simplify' shp) (AlgSimplify.simplify' strd)---- | Dynamically determine if two 'LMADDim' are equal.------ True if the dynamic values of their constituents are equal.-dynamicEqualsLMADDim :: Eq num => LMADDim (TPrimExp t num) -> LMADDim (TPrimExp t num) -> TPrimExp Bool num-dynamicEqualsLMADDim dim1 dim2 =-  ldStride dim1 .==. ldStride dim2-    .&&. ldShape dim1 .==. ldShape dim2-    .&&. fromBool (ldPerm dim1 == ldPerm dim2)-    .&&. fromBool (ldMon dim1 == ldMon dim2)---- | Dynamically determine if two 'LMAD' are equal.------ True if offset and constituent 'LMADDim' are equal.-dynamicEqualsLMAD :: Eq num => LMAD (TPrimExp t num) -> LMAD (TPrimExp t num) -> TPrimExp Bool num-dynamicEqualsLMAD lmad1 lmad2 =-  lmadOffset lmad1 .==. lmadOffset lmad2-    .&&. foldr-      ((.&&.) . uncurry dynamicEqualsLMADDim)-      true-      (zip (lmadDims lmad1) (lmadDims lmad2))

@@ -0,0 +1,470 @@+-- | This module contains a representation of linear-memory accessor+-- descriptors (LMAD); see work by Zhu, Hoeflinger and David.+module Futhark.IR.Mem.LMAD+  ( Shape,+    LMAD (..),+    LMADDim (..),+    Monotonicity (..),+    Permutation,+    lmadShape,+    lmadShapeBase,+    substituteInLMAD,+    permuteInv,+    permuteFwd,+    conservativeFlatten,+    disjoint,+    disjoint2,+    disjoint3,+    dynamicEqualsLMAD,+    lmadPermutation,+    makeRotIota,+    invertMonotonicity,+  )+where++import Control.Category+import Control.Monad+import Data.Function (on, (&))+import Data.List (elemIndex, partition, sortBy, zipWith4)+import Data.Map.Strict qualified as M+import Data.Maybe (fromJust, isNothing)+import Data.Traversable+import Futhark.Analysis.AlgSimplify qualified as AlgSimplify+import Futhark.Analysis.PrimExp+import Futhark.Analysis.PrimExp.Convert+import Futhark.IR.Mem.Interval+import Futhark.IR.Prop+import Futhark.IR.Syntax (Type)+import Futhark.IR.Syntax.Core (VName (..))+import Futhark.Transform.Rename+import Futhark.Transform.Substitute+import Futhark.Util+import Futhark.Util.IntegralExp+import Futhark.Util.Pretty+import Prelude hiding (gcd, id, mod, (.))++-- | The shape of an index function.+type Shape num = [num]++type Permutation = [Int]++-- | The physical element ordering alongside a dimension, i.e. the+-- sign of the stride.+data Monotonicity+  = -- | Increasing.+    Inc+  | -- | Decreasing.+    Dec+  | -- | Unknown.+    Unknown+  deriving (Show, Eq)++-- | A single dimension in an 'LMAD'.+data LMADDim num = LMADDim+  { ldStride :: num,+    ldShape :: num,+    ldPerm :: Int,+    ldMon :: Monotonicity+  }+  deriving (Show, Eq)++instance Ord Monotonicity where+  (<=) _ Inc = True+  (<=) Unknown _ = True+  (<=) _ Unknown = False+  (<=) Inc Dec = False+  (<=) _ Dec = True++instance Ord num => Ord (LMADDim num) where+  (LMADDim s1 q1 p1 m1) <= (LMADDim s2 q2 p2 m2) =+    ([q1, s1] < [q2, s2])+      || ( ([q1, s1] == [q2, s2])+             && ( (p1 < p2)+                    || ( (p1 == p2)+                           && (m1 <= m2)+                       )+                )+         )++-- | LMAD's representation consists of a general offset and for each dimension a+-- stride, number of elements (or shape), permutation, and+-- monotonicity. Note that the permutation is not strictly necessary in that the+-- permutation can be performed directly on LMAD dimensions, but then it is+-- difficult to extract the permutation back from an LMAD.+--+-- LMAD algebra is closed under composition w.r.t. operators such as+-- permute, index and slice.  However, other operations, such as+-- reshape, cannot always be represented inside the LMAD algebra.+--+-- It follows that the general representation of an index function is a list of+-- LMADS, in which each following LMAD in the list implicitly corresponds to an+-- irregular reshaping operation.+--+-- However, we expect that the common case is when the index function is one+-- LMAD -- we call this the "nice" representation.+--+-- Finally, the list of LMADs is kept in an @IxFun@ together with the shape of+-- the original array, and a bit to indicate whether the index function is+-- contiguous, i.e., if we instantiate all the points of the current index+-- function, do we get a contiguous memory interval?+--+-- By definition, the LMAD \( \sigma + \{ (n_1, s_1), \ldots, (n_k, s_k) \} \),+-- where \(n\) and \(s\) denote the shape and stride of each dimension, denotes+-- the set of points:+--+-- \[+--    \{ ~ \sigma + i_1 * s_1 + \ldots + i_m * s_m ~ | ~ 0 \leq i_1 < n_1, \ldots, 0 \leq i_m < n_m ~ \}+-- \]+data LMAD num = LMAD+  { lmadOffset :: num,+    lmadDims :: [LMADDim num]+  }+  deriving (Show, Eq, Ord)++instance Pretty Monotonicity where+  pretty = pretty . show++instance Pretty num => Pretty (LMAD num) where+  pretty (LMAD offset dims) =+    braces . semistack $+      [ "offset:" <+> group (pretty offset),+        "strides:" <+> p ldStride,+        "shape:" <+> p ldShape,+        "permutation:" <+> p ldPerm,+        "monotonicity:" <+> p ldMon+      ]+    where+      p f = group $ brackets $ align $ commasep $ map (pretty . f) dims++instance Substitute num => Substitute (LMAD num) where+  substituteNames substs = fmap $ substituteNames substs++instance Substitute num => Rename (LMAD num) where+  rename = substituteRename++instance FreeIn num => FreeIn (LMAD num) where+  freeIn' = foldMap freeIn'++instance FreeIn num => FreeIn (LMADDim num) where+  freeIn' (LMADDim s n _ _) = freeIn' s <> freeIn' n++instance Functor LMAD where+  fmap = fmapDefault++instance Foldable LMAD where+  foldMap = foldMapDefault++instance Traversable LMAD where+  traverse f (LMAD offset dims) =+    LMAD <$> f offset <*> traverse f' dims+    where+      f' (LMADDim s n p m) = LMADDim <$> f s <*> f n <*> pure p <*> pure m++invertMonotonicity :: Monotonicity -> Monotonicity+invertMonotonicity Inc = Dec+invertMonotonicity Dec = Inc+invertMonotonicity Unknown = Unknown++lmadPermutation :: LMAD num -> Permutation+lmadPermutation = map ldPerm . lmadDims++-- | Substitute a name with a PrimExp in an LMAD.+substituteInLMAD ::+  Ord a =>+  M.Map a (TPrimExp t a) ->+  LMAD (TPrimExp t a) ->+  LMAD (TPrimExp t a)+substituteInLMAD tab (LMAD offset dims) =+  let offset' = sub offset+      dims' =+        map+          ( \(LMADDim s n p m) ->+              LMADDim+                (sub s)+                (sub n)+                p+                m+          )+          dims+   in LMAD offset' dims'+  where+    tab' = fmap untyped tab+    sub = TPrimExp . substituteInPrimExp tab' . untyped++-- | Shape of an LMAD.+lmadShape :: LMAD num -> Shape num+lmadShape lmad = permuteInv (lmadPermutation lmad) $ lmadShapeBase lmad++-- | Shape of an LMAD, ignoring permutations.+lmadShapeBase :: LMAD num -> Shape num+lmadShapeBase = map ldShape . lmadDims++permuteFwd :: Permutation -> [a] -> [a]+permuteFwd ps elems = map (elems !!) ps++permuteInv :: Permutation -> [a] -> [a]+permuteInv ps elems = map snd $ sortBy (compare `on` fst) $ zip ps elems++-- | Generalised iota with user-specified offset and rotates.+makeRotIota ::+  IntegralExp num =>+  Monotonicity ->+  -- | Offset+  num ->+  -- | Shape+  [num] ->+  LMAD num+makeRotIota mon off ns+  | mon == Inc || mon == Dec =+      let rk = length ns+          ss0 = reverse $ take rk $ scanl (*) 1 $ reverse ns+          ss =+            if mon == Inc+              then ss0+              else map (* (-1)) ss0+          ps = map fromIntegral [0 .. rk - 1]+          fi = replicate rk mon+       in LMAD off $ zipWith4 LMADDim ss ns ps fi+  | otherwise = error "makeRotIota: requires Inc or Dec"++-- | Computes the maximum span of an 'LMAD'. The result is the lowest and+-- highest flat values representable by that 'LMAD'.+flatSpan :: LMAD (TPrimExp Int64 VName) -> TPrimExp Int64 VName+flatSpan (LMAD _ dims) =+  foldr+    ( \dim upper ->+        let spn = ldStride dim * (ldShape dim - 1)+         in -- If you've gotten this far, you've already lost+            spn + upper+    )+    0+    dims++-- | Conservatively flatten a list of LMAD dimensions+--+-- Since not all LMADs can actually be flattened, we try to overestimate the+-- flattened array instead. This means that any "holes" in betwen dimensions+-- will get filled out.+-- conservativeFlatten :: (IntegralExp e, Ord e, Pretty e) => LMAD e -> LMAD e+conservativeFlatten :: LMAD (TPrimExp Int64 VName) -> Maybe (LMAD (TPrimExp Int64 VName))+conservativeFlatten (LMAD offset []) =+  pure $ LMAD offset [LMADDim 1 1 0 Inc]+conservativeFlatten l@(LMAD _ [_]) =+  pure l+conservativeFlatten l@(LMAD offset dims) = do+  strd <-+    foldM+      gcd+      (ldStride $ head dims)+      $ map ldStride dims+  pure $ LMAD offset [LMADDim strd (shp + 1) 0 Unknown]+  where+    shp = flatSpan l++-- | Very conservative GCD calculation. Returns 'Nothing' if the result cannot+-- be immediately determined. Does not recurse at all.+gcd :: TPrimExp Int64 VName -> TPrimExp Int64 VName -> Maybe (TPrimExp Int64 VName)+gcd x y = gcd' (abs x) (abs y)+  where+    gcd' a b | a == b = Just a+    gcd' 1 _ = Just 1+    gcd' _ 1 = Just 1+    gcd' a 0 = Just a+    gcd' _ _ = Nothing -- gcd' b (a `Futhark.Util.IntegralExp.rem` b)++-- | Returns @True@ if the two 'LMAD's could be proven disjoint.+--+-- Uses some best-approximation heuristics to determine disjointness. For two+-- 1-dimensional arrays, we can guarantee whether or not they are disjoint, but+-- as soon as more than one dimension is involved, things get more+-- tricky. Currently, we try to 'conservativelyFlatten' any LMAD with more than+-- one dimension.+disjoint :: [(VName, PrimExp VName)] -> Names -> LMAD (TPrimExp Int64 VName) -> LMAD (TPrimExp Int64 VName) -> Bool+disjoint less_thans non_negatives (LMAD offset1 [dim1]) (LMAD offset2 [dim2]) =+  doesNotDivide (gcd (ldStride dim1) (ldStride dim2)) (offset1 - offset2)+    || AlgSimplify.lessThanish+      less_thans+      non_negatives+      (offset2 + (ldShape dim2 - 1) * ldStride dim2)+      offset1+    || AlgSimplify.lessThanish+      less_thans+      non_negatives+      (offset1 + (ldShape dim1 - 1) * ldStride dim1)+      offset2+  where+    doesNotDivide :: Maybe (TPrimExp Int64 VName) -> TPrimExp Int64 VName -> Bool+    doesNotDivide (Just x) y =+      Futhark.Util.IntegralExp.mod y x+        & untyped+        & constFoldPrimExp+        & TPrimExp+        & (.==.) (0 :: TPrimExp Int64 VName)+        & primBool+        & maybe False not+    doesNotDivide _ _ = False+disjoint less_thans non_negatives lmad1 lmad2 =+  case (conservativeFlatten lmad1, conservativeFlatten lmad2) of+    (Just lmad1', Just lmad2') -> disjoint less_thans non_negatives lmad1' lmad2'+    _ -> False++disjoint2 :: scope -> asserts -> [(VName, PrimExp VName)] -> Names -> LMAD (TPrimExp Int64 VName) -> LMAD (TPrimExp Int64 VName) -> Bool+disjoint2 _ _ less_thans non_negatives lmad1 lmad2 =+  let (offset1, interval1) = lmadToIntervals lmad1+      (offset2, interval2) = lmadToIntervals lmad2+      (neg_offset, pos_offset) =+        partition AlgSimplify.negated $+          offset1 `AlgSimplify.sub` offset2+      (interval1', interval2') =+        unzip $+          sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride . fst)) $+            intervalPairs interval1 interval2+   in case ( distributeOffset pos_offset interval1',+             distributeOffset (map AlgSimplify.negate neg_offset) interval2'+           ) of+        (Just interval1'', Just interval2'') ->+          isNothing+            ( selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval1''+            )+            && isNothing+              ( selfOverlap () () less_thans (map (flip LeafExp $ IntType Int64) $ namesToList non_negatives) interval2''+              )+            && not+              ( all+                  (uncurry (intervalOverlap less_thans non_negatives))+                  (zip interval1'' interval2'')+              )+        _ ->+          False++disjoint3 :: M.Map VName Type -> [PrimExp VName] -> [(VName, PrimExp VName)] -> [PrimExp VName] -> LMAD (TPrimExp Int64 VName) -> LMAD (TPrimExp Int64 VName) -> Bool+disjoint3 scope asserts less_thans non_negatives lmad1 lmad2 =+  let (offset1, interval1) = lmadToIntervals lmad1+      (offset2, interval2) = lmadToIntervals lmad2+      interval1' = fixPoint (mergeDims . joinDims) $ sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride)) interval1+      interval2' = fixPoint (mergeDims . joinDims) $ sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride)) interval2+      (interval1'', interval2'') =+        unzip $+          sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride . fst)) $+            intervalPairs interval1' interval2'+   in disjointHelper 4 interval1'' interval2'' $ offset1 `AlgSimplify.sub` offset2+  where+    disjointHelper :: Int -> [Interval] -> [Interval] -> AlgSimplify.SofP -> Bool+    disjointHelper 0 _ _ _ = False+    disjointHelper i is10 is20 offset =+      let (is1, is2) =+            unzip $+              sortBy (flip AlgSimplify.compareComplexity `on` (AlgSimplify.simplify0 . untyped . stride . fst)) $+                intervalPairs is10 is20+          (neg_offset, pos_offset) = partition AlgSimplify.negated offset+       in case ( distributeOffset pos_offset is1,+                 distributeOffset (map AlgSimplify.negate neg_offset) is2+               ) of+            (Just is1', Just is2') -> do+              let overlap1 = selfOverlap scope asserts less_thans non_negatives is1'+              let overlap2 = selfOverlap scope asserts less_thans non_negatives is2'+              case (overlap1, overlap2) of+                (Nothing, Nothing) ->+                  case namesFromList <$> mapM justLeafExp non_negatives of+                    Just non_negatives' ->+                      not $+                        all+                          (uncurry (intervalOverlap less_thans non_negatives'))+                          (zip is1 is2)+                    _ -> False+                (Just overlapping_dim, _) ->+                  let expanded_offset = AlgSimplify.simplifySofP' <$> expandOffset offset is1+                      splits = splitDim overlapping_dim is1'+                   in all (\(new_offset, new_is1) -> disjointHelper (i - 1) (joinDims new_is1) (joinDims is2') new_offset) splits+                        || maybe False (disjointHelper (i - 1) is1 is2) expanded_offset+                (_, Just overlapping_dim) ->+                  let expanded_offset = AlgSimplify.simplifySofP' <$> expandOffset offset is2+                      splits = splitDim overlapping_dim is2'+                   in all+                        ( \(new_offset, new_is2) ->+                            disjointHelper (i - 1) (joinDims is1') (joinDims new_is2) $+                              map AlgSimplify.negate new_offset+                        )+                        splits+                        || maybe False (disjointHelper (i - 1) is1 is2) expanded_offset+            _ -> False++joinDims :: [Interval] -> [Interval]+joinDims = helper []+  where+    helper acc [] = reverse acc+    helper acc [x] = reverse $ x : acc+    helper acc (x : y : rest) =+      if stride x == stride y && lowerBound x == 0 && lowerBound y == 0+        then helper acc $ x {numElements = numElements x * numElements y} : rest+        else helper (x : acc) (y : rest)++mergeDims :: [Interval] -> [Interval]+mergeDims = helper [] . reverse+  where+    helper acc [] = acc+    helper acc [x] = x : acc+    helper acc (x : y : rest) =+      if stride x * numElements x == stride y && lowerBound x == 0 && lowerBound y == 0+        then helper acc $ x {numElements = numElements x * numElements y} : rest+        else helper (x : acc) (y : rest)++splitDim :: Interval -> [Interval] -> [(AlgSimplify.SofP, [Interval])]+splitDim overlapping_dim0 is+  | [st] <- AlgSimplify.simplify0 $ untyped $ stride overlapping_dim0,+    [st1] <- AlgSimplify.simplify0 $ untyped $ stride overlapping_dim,+    [spn] <- AlgSimplify.simplify0 $ untyped $ stride overlapping_dim * numElements overlapping_dim,+    lowerBound overlapping_dim == 0,+    Just big_dim_elems <- AlgSimplify.maybeDivide spn st,+    Just small_dim_elems <- AlgSimplify.maybeDivide st st1 =+      [ ( [],+          init before+            <> [ Interval 0 (isInt64 $ AlgSimplify.prodToExp big_dim_elems) (stride overlapping_dim0),+                 Interval 0 (isInt64 $ AlgSimplify.prodToExp small_dim_elems) (stride overlapping_dim)+               ]+            <> after+        )+      ]+  | otherwise =+      let shrunk_dim = overlapping_dim {numElements = numElements overlapping_dim - 1}+          point_offset = AlgSimplify.simplify0 $ untyped $ (numElements overlapping_dim - 1 + lowerBound overlapping_dim) * stride overlapping_dim+       in [ (point_offset, before <> after),+            ([], before <> [shrunk_dim] <> after)+          ]+  where+    (before, overlapping_dim, after) =+      fromJust $+        elemIndex overlapping_dim0 is+          >>= (flip focusNth is . (+ 1))++lmadToIntervals :: LMAD (TPrimExp Int64 VName) -> (AlgSimplify.SofP, [Interval])+lmadToIntervals (LMAD offset []) = (AlgSimplify.simplify0 $ untyped offset, [Interval 0 1 1])+lmadToIntervals lmad@(LMAD offset dims0) =+  (offset', map helper $ permuteInv (lmadPermutation lmad) dims0)+  where+    offset' = AlgSimplify.simplify0 $ untyped offset++    helper :: LMADDim (TPrimExp Int64 VName) -> Interval+    helper (LMADDim strd shp _ _) = do+      Interval 0 (AlgSimplify.simplify' shp) (AlgSimplify.simplify' strd)++-- | Dynamically determine if two 'LMADDim' are equal.+--+-- True if the dynamic values of their constituents are equal.+dynamicEqualsLMADDim :: Eq num => LMADDim (TPrimExp t num) -> LMADDim (TPrimExp t num) -> TPrimExp Bool num+dynamicEqualsLMADDim dim1 dim2 =+  ldStride dim1 .==. ldStride dim2+    .&&. ldShape dim1 .==. ldShape dim2+    .&&. fromBool (ldPerm dim1 == ldPerm dim2)+    .&&. fromBool (ldMon dim1 == ldMon dim2)++-- | Dynamically determine if two 'LMAD' are equal.+--+-- True if offset and constituent 'LMADDim' are equal.+dynamicEqualsLMAD :: Eq num => LMAD (TPrimExp t num) -> LMAD (TPrimExp t num) -> TPrimExp Bool num+dynamicEqualsLMAD lmad1 lmad2 =+  lmadOffset lmad1 .==. lmadOffset lmad2+    .&&. foldr+      ((.&&.) . uncurry dynamicEqualsLMADDim)+      true+      (zip (lmadDims lmad1) (lmadDims lmad2))

@@ -144,7 +144,7 @@                 v_copy <- newVName $ baseString v <> "_nonext_copy"                 let v_pat =                       Pat [PatElem v_copy $ MemArray pt shape u $ ArrayIn mem ixfun]-                addStm $ mkWiseStm v_pat (defAux ()) $ BasicOp (Copy v)+                addStm $ mkWiseStm v_pat (defAux ()) $ BasicOp $ Replicate mempty $ Var v                 pure $ SubExpRes cs $ Var v_copy             | Just mem <- lookup (patElemName pat_elem) oldmem_to_mem =                 pure $ SubExpRes cs $ Var mem

@@ -1,20 +1,26 @@ -- | Parser for the Futhark core language. module Futhark.IR.Parse-  ( parseSOACS,+  ( -- * Programs+    parseSOACS,     parseGPU,     parseGPUMem,     parseMC,     parseMCMem,     parseSeq,     parseSeqMem,++    -- * Fragments+    parseDeclExtType,+    parseDeclType,   ) where  import Data.Char (isAlpha) import Data.Functor-import Data.List (zipWith4)+import Data.List (singleton, zipWith4) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE+import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T import Data.Void@@ -54,13 +60,13 @@ pVName :: Parser VName pVName = lexeme $ do   (s, tag) <--    satisfy constituent+    choice [exprBox, singleton <$> satisfy constituent]       `manyTill_` try pTag       <?> "variable name"-  pure $ VName (nameFromString s) tag+  pure $ VName (nameFromString $ concat s) tag   where-    pTag =-      "_" *> L.decimal <* notFollowedBy (satisfy constituent)+    pTag = "_" *> L.decimal <* notFollowedBy (satisfy constituent)+    exprBox = ("<{" <>) . (<> "}>") <$> (chunk "<{" *> manyTill anySingle (chunk "}>"))  pBool :: Parser Bool pBool = choice [keyword "true" $> True, keyword "false" $> False]@@ -257,7 +263,7 @@       keyword "trace"         $> uncurry (Opaque . OpaqueTrace)         <*> parens ((,) <$> pStringLiteral <* pComma <*> pSubExp),-      keyword "copy" $> Copy <*> parens pVName,+      keyword "copy" $> Replicate mempty . Var <*> parens pVName,       keyword "assert"         *> parens           ( Assert@@ -267,9 +273,6 @@               <* pComma               <*> pErrorLoc           ),-      keyword "rotate"-        *> parens-          (Rotate <$> parens (pSubExp `sepBy` pComma) <* pComma <*> pVName),       keyword "replicate"         *> parens (Replicate <$> pShape <* pComma <*> pSubExp),       keyword "reshape"@@ -373,9 +376,15 @@     pExpDec :: ExpDec rep   } -pRetTypes :: PR rep -> Parser [RetType rep]-pRetTypes pr = braces $ pRetType pr `sepBy` pComma+pRetAls :: Parser RetAls+pRetAls = fromMaybe (RetAls mempty mempty) <$> optional p+  where+    p = lexeme "#" *> parens (RetAls <$> pInts <* pComma <*> pInts)+    pInts = brackets $ pInt `sepBy` pComma +pRetTypes :: PR rep -> Parser [(RetType rep, RetAls)]+pRetTypes pr = braces $ ((,) <$> pRetType pr <*> pRetAls) `sepBy` pComma+ pBranchTypes :: PR rep -> Parser [BranchType rep] pBranchTypes pr = braces $ pBranchType pr `sepBy` pComma @@ -1107,11 +1116,14 @@   where     op = pMemOp $ pMCOp prMCMem empty -parseRep :: PR rep -> FilePath -> T.Text -> Either T.Text (Prog rep)-parseRep pr fname s =+parseFull :: Parser a -> FilePath -> T.Text -> Either T.Text a+parseFull p fname s =   either (Left . T.pack . errorBundlePretty) Right $-    parse (whitespace *> pProg pr <* eof) fname s+    parse (whitespace *> p <* eof) fname s +parseRep :: PR rep -> FilePath -> T.Text -> Either T.Text (Prog rep)+parseRep = parseFull . pProg+ parseSOACS :: FilePath -> T.Text -> Either T.Text (Prog SOACS) parseSOACS = parseRep prSOACS @@ -1132,3 +1144,9 @@  parseMCMem :: FilePath -> T.Text -> Either T.Text (Prog MCMem) parseMCMem = parseRep prMCMem++parseDeclExtType :: FilePath -> T.Text -> Either T.Text DeclExtType+parseDeclExtType = parseFull pDeclExtType++parseDeclType :: FilePath -> T.Text -> Either T.Text DeclType+parseDeclType = parseFull pDeclType

@@ -43,9 +43,6 @@   pretty Commutative = "commutative"   pretty Noncommutative = "noncommutative" -instance Pretty NoUniqueness where-  pretty _ = mempty- instance Pretty Shape where   pretty = mconcat . map (brackets . pretty) . shapeDims @@ -220,6 +217,7 @@   pretty (Iota e x s et) = "iota" <> et' <> apply [pretty e, pretty x, pretty s]     where       et' = pretty $ show $ primBitSize $ IntType et+  pretty (Replicate (Shape []) e) = "copy" <> parens (pretty e)   pretty (Replicate ne ve) =     "replicate" <> apply [pretty ne, align (pretty ve)]   pretty (Scratch t shape) =@@ -230,11 +228,8 @@     "coerce" <> apply [pretty shape, pretty e]   pretty (Rearrange perm e) =     "rearrange" <> apply [apply (map pretty perm), pretty e]-  pretty (Rotate es e) =-    "rotate" <> apply [apply (map pretty es), pretty e]   pretty (Concat i (x :| xs) w) =     "concat" <> "@" <> pretty i <> apply (pretty w : pretty x : map pretty xs)-  pretty (Copy e) = "copy" <> parens (pretty e)   pretty (Manifest perm e) = "manifest" <> apply [apply (map pretty perm), pretty e]   pretty (Assert e msg (loc, _)) =     "assert" <> apply [pretty e, pretty msg, pretty $ show $ locStr loc]@@ -261,6 +256,16 @@   pretty (Case vs b) =     "case" <+> ppTuple' (map (maybe "_" pretty) vs) <+> "->" <+> maybeNest b +prettyRet :: Pretty t => (t, RetAls) -> Doc a+prettyRet (t, RetAls pals rals)+  | pals == mempty,+    rals == mempty =+      pretty t+  | otherwise =+      pretty t <> "#" <> parens (pl pals <> comma <+> pl rals)+  where+    pl = brackets . commasep . map pretty+ instance PrettyRep rep => Pretty (Exp rep) where   pretty (Match [c] [Case [Just (BoolValue True)] t] f (MatchDec ret ifsort)) =     "if"@@ -296,7 +301,7 @@       <+> pretty (nameToString fname)         <> apply (map (align . prettyArg) args)       </> colon-      <+> braces (commasep $ map pretty ret)+      <+> braces (commasep $ map prettyRet ret)     where       prettyArg (arg, Consume) = "*" <> pretty arg       prettyArg (arg, _) = pretty arg@@ -379,7 +384,7 @@       fun         </> indent 2 (pretty (nameToString name))         <+> parens (commastack $ map pretty fparams)-        </> indent 2 (colon <+> align (ppTupleLines' $ map pretty rettype))+        </> indent 2 (colon <+> align (ppTupleLines' $ map prettyRet rettype))         <+> equals         <+> nestedBlock "{" "}" (pretty body)     where

@@ -118,7 +118,6 @@     safeBasicOp Manifest {} = True     safeBasicOp Iota {} = True     safeBasicOp Replicate {} = True-    safeBasicOp Copy {} = True     safeBasicOp _ = False safeExp (DoLoop _ _ body) = safeBody body safeExp (Apply fname _ _ _) =

@@ -71,9 +71,7 @@ basicOpAliases Scratch {} = [mempty] basicOpAliases (Reshape _ _ e) = [vnameAliases e] basicOpAliases (Rearrange _ e) = [vnameAliases e]-basicOpAliases (Rotate _ e) = [vnameAliases e] basicOpAliases Concat {} = [mempty]-basicOpAliases Copy {} = [mempty] basicOpAliases Manifest {} = [mempty] basicOpAliases Assert {} = [mempty] basicOpAliases UpdateAcc {} = [mempty]@@ -84,23 +82,30 @@   where     (alses, conses) = unzip l -returnAliases :: [TypeBase shape Uniqueness] -> [(Names, Diet)] -> [Names]-returnAliases rts args = map returnType' rts+funcallAliases ::+  [PatElem dec] ->+  [(SubExp, Diet)] ->+  [(TypeBase shape Uniqueness, RetAls)] ->+  [Names]+funcallAliases pes args = map onType   where-    returnType' (Array _ _ Nonunique) =-      mconcat $ map (uncurry maskAliases) args-    returnType' (Array _ _ Unique) =-      mempty-    returnType' (Prim _) =-      mempty-    returnType' Acc {} =-      error "returnAliases Acc"-    returnType' Mem {} =-      mconcat $ map (uncurry maskAliases) args+    getAls als is = mconcat $ map fst $ filter ((`elem` is) . snd) $ zip als [0 ..]+    arg_als = map (subExpAliases . fst) args+    res_als = map (oneName . patElemName) pes+    onType (_t, RetAls pals rals) = getAls arg_als pals <> getAls res_als rals -funcallAliases :: [(SubExp, Diet)] -> [TypeBase shape Uniqueness] -> [Names]-funcallAliases args t =-  returnAliases t [(subExpAliases se, d) | (se, d) <- args]+mutualAliases :: Names -> [PatElem dec] -> [Names] -> [Names]+mutualAliases bound pes als = zipWith grow (map patElemName pes) als+  where+    bound_als = map (`namesIntersection` bound) als+    grow v names = (names <> pe_names) `namesSubtract` bound+      where+        pe_names =+          namesFromList+            . filter (/= v)+            . map (patElemName . fst)+            . filter (namesIntersect names . snd)+            $ zip pes bound_als  -- | The aliases of an expression, one for each pattern element. --@@ -111,27 +116,19 @@ expAliases pes (Match _ cases defbody _) =   -- Repeat mempty in case the pattern has more elements (this   -- implies a type error).-  zipWith grow (map patElemName pes) $ als ++ repeat mempty+  mutualAliases bound pes $ als ++ repeat mempty   where     als = matchAliases $ onBody defbody : map (onBody . caseBody) cases     onBody body = (bodyAliases body, consumedInBody body)     bound = foldMap boundInBody $ defbody : map caseBody cases-    grow v names = (names <> pe_names) `namesSubtract` bound-      where-        pe_names =-          namesFromList-            . filter (/= v)-            . map (patElemName . fst)-            . filter (namesIntersect names . snd)-            $ zip pes als expAliases _ (BasicOp op) = basicOpAliases op-expAliases _ (DoLoop merge _ loopbody) = do-  (p, als) <--    transitive . zip params $ zipWith mappend arg_aliases (bodyAliases loopbody)-  let als' = als `namesSubtract` param_names-  if unique $ paramDeclType p-    then pure mempty-    else pure $ als' `namesSubtract` bound+expAliases pes (DoLoop merge _ loopbody) =+  mutualAliases (bound <> param_names) pes $ do+    (p, als) <-+      transitive . zip params $ zipWith (<>) arg_aliases (bodyAliases loopbody)+    if unique $ paramDeclType p+      then pure mempty+      else pure als   where     bound = boundInBody loopbody     arg_aliases = map (subExpAliases . snd) merge@@ -145,8 +142,8 @@       where         look v = maybe mempty snd $ find ((== v) . paramName . fst) merge_and_als         expand als = als <> foldMap look (namesToList als)-expAliases _ (Apply _ args t _) =-  funcallAliases args $ map declExtTypeOf t+expAliases pes (Apply _ args t _) =+  funcallAliases pes args $ map (first declExtTypeOf) t expAliases _ (WithAcc inputs lam) =   concatMap inputAliases inputs     ++ drop num_accs (map (`namesSubtract` boundInBody body) $ bodyAliases body)@@ -155,11 +152,6 @@     inputAliases (_, arrs, _) = replicate (length arrs) mempty     num_accs = length inputs expAliases _ (Op op) = opAliases op--maskAliases :: Names -> Diet -> Names-maskAliases _ Consume = mempty-maskAliases _ ObservePrim = mempty-maskAliases als Observe = als  -- | The variables consumed in this statement. consumedInStm :: Aliased rep => Stm rep -> Names

@@ -239,7 +239,7 @@   where   freeIn' (FunDef _ _ _ rettype params body) =     fvBind (namesFromList $ map paramName params) $-      freeIn' rettype <> freeIn' params <> freeIn' body+      foldMap (freeIn' . fst) rettype <> freeIn' params <> freeIn' body  instance   ( FreeDec (ExpDec rep),

@@ -109,14 +109,10 @@   result <$> lookupType e   where     result t = [rearrangeType perm t]-basicOpType (Rotate _ e) =-  pure <$> lookupType e basicOpType (Concat i (x :| _) ressize) =   result <$> lookupType x   where     result xt = [setDimSize i xt ressize]-basicOpType (Copy v) =-  pure <$> lookupType v basicOpType (Manifest _ v) =   pure <$> lookupType v basicOpType Assert {} =@@ -129,7 +125,7 @@   (HasScope rep m, TypedOp (Op rep)) =>   Exp rep ->   m [ExtType]-expExtType (Apply _ _ rt _) = pure $ map (fromDecl . declExtTypeOf) rt+expExtType (Apply _ _ rt _) = pure $ map (fromDecl . declExtTypeOf . fst) rt expExtType (Match _ _ _ rt) = pure $ map extTypeOf $ matchReturns rt expExtType (DoLoop merge _ _) =   pure $ loopExtType $ map fst merge

@@ -589,6 +589,9 @@ instance ExtTyped ExtType where   extTypeOf = id +instance ExtTyped DeclExtType where+  extTypeOf = fromDecl . declExtTypeOf+ -- | Typeclass for things that contain 'DeclExtType's. class FixExt t => DeclExtTyped t where   declExtTypeOf :: t -> DeclExtType

@@ -15,6 +15,7 @@   ) where +import Data.Bitraversable import Futhark.IR.Syntax import Futhark.IR.Traversals @@ -46,7 +47,7 @@ rephraseFunDef rephraser fundec = do   body' <- rephraseBody rephraser $ funDefBody fundec   params' <- mapM (rephraseParam $ rephraseFParamDec rephraser) $ funDefParams fundec-  rettype' <- mapM (rephraseRetType rephraser) $ funDefRetType fundec+  rettype' <- mapM (bitraverse (rephraseRetType rephraser) pure) $ funDefRetType fundec   pure fundec {funDefBody = body', funDefParams = params', funDefRetType = rettype'}  -- | Rephrase an expression.

@@ -28,7 +28,7 @@ -- a list of these will be used.  It should contain at least the -- information contained in an 'ExtType', but may have more, notably -- an existential context.-class (Show rt, Eq rt, Ord rt, DeclExtTyped rt) => IsRetType rt where+class (Show rt, Eq rt, Ord rt, ExtTyped rt, DeclExtTyped rt) => IsRetType rt where   -- | Contruct a return type from a primitive type.   primRetType :: PrimType -> rt 

@@ -271,7 +271,7 @@             where               e inp = case patElemType outId of                 Acc {} -> BasicOp $ SubExp $ Var inp-                _ -> BasicOp (Copy inp)+                _ -> BasicOp (Replicate mempty (Var inp))           checkInvariance (outId, SubExpRes _ e, t) (invariant, mapresult, rettype')             | freeOrConst e =                 ( (Pat [outId], BasicOp $ Replicate (Shape [w]) e) : invariant,@@ -308,7 +308,7 @@       partitionEithers $ map isInvariantRes $ zip3 map_ts map_pes map_res,     not $ null invariant_map = Simplify $ do       forM_ invariant_map $ \(pe, arr) ->-        letBind (Pat [pe]) $ BasicOp $ Copy arr+        letBind (Pat [pe]) $ BasicOp $ Replicate mempty $ Var arr        let (variant_map_ts, variant_map_pes, variant_map_res) = unzip3 variant_map           lam' =@@ -462,7 +462,7 @@                       }               auxing aux $ letBind (Pat pes') $ Op $ Screma w arrs $ mapSOAC fun'               forM_ copies $ \(from, to) ->-                letBind (Pat [to]) $ BasicOp $ Copy $ patElemName from+                letBind (Pat [to]) $ BasicOp $ Replicate mempty $ Var $ patElemName from   where     checkForDuplicates (ses_ts_pes', copies) (se, t, pe)       | Just (_, _, pe') <- find (\(x, _, _) -> resSubExp x == resSubExp se) ses_ts_pes' =@@ -493,12 +493,6 @@     not $ UT.isConsumed (patElemName map_pe) used =       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 mapOpToOp _ _ _ _ = Skip  isMapWithOp ::@@ -696,7 +690,6 @@ data ArrayOp   = ArrayIndexing Certs VName (Slice SubExp)   | ArrayRearrange Certs VName [Int]-  | ArrayRotate Certs VName [SubExp]   | ArrayReshape Certs VName ReshapeKind Shape   | ArrayCopy Certs VName   | -- | Never constructed.@@ -706,7 +699,6 @@ arrayOpArr :: ArrayOp -> VName arrayOpArr (ArrayIndexing _ arr _) = arr arrayOpArr (ArrayRearrange _ arr _) = arr-arrayOpArr (ArrayRotate _ arr _) = arr arrayOpArr (ArrayReshape _ arr _ _) = arr arrayOpArr (ArrayCopy _ arr) = arr arrayOpArr (ArrayVar _ arr) = arr@@ -714,7 +706,6 @@ arrayOpCerts :: ArrayOp -> Certs arrayOpCerts (ArrayIndexing cs _ _) = cs arrayOpCerts (ArrayRearrange cs _ _) = cs-arrayOpCerts (ArrayRotate cs _ _) = cs arrayOpCerts (ArrayReshape cs _ _ _) = cs arrayOpCerts (ArrayCopy cs _) = cs arrayOpCerts (ArrayVar cs _) = cs@@ -724,11 +715,9 @@   Just $ ArrayIndexing cs arr slice isArrayOp cs (BasicOp (Rearrange perm arr)) =   Just $ ArrayRearrange cs arr perm-isArrayOp cs (BasicOp (Rotate rots arr)) =-  Just $ ArrayRotate cs arr rots isArrayOp cs (BasicOp (Reshape k new_shape arr)) =   Just $ ArrayReshape cs arr k new_shape-isArrayOp cs (BasicOp (Copy arr)) =+isArrayOp cs (BasicOp (Replicate (Shape []) (Var arr))) =   Just $ ArrayCopy cs arr isArrayOp _ _ =   Nothing@@ -736,9 +725,8 @@ fromArrayOp :: ArrayOp -> (Certs, 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 (ArrayReshape cs arr k new_shape) = (cs, BasicOp $ Reshape k new_shape arr)-fromArrayOp (ArrayCopy cs arr) = (cs, BasicOp $ Copy arr)+fromArrayOp (ArrayCopy cs arr) = (cs, BasicOp $ Replicate mempty $ Var arr) fromArrayOp (ArrayVar cs arr) = (cs, BasicOp $ SubExp $ Var arr)  arrayOps ::@@ -935,9 +923,6 @@       arr `elem` map_param_names         && all (`ST.elem` vtable) (namesToList $ freeIn cs)         && not (null perm)-    arrayIsMapParam (_, ArrayRotate cs arr rots) =-      arr `elem` map_param_names-        && all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn rots)     arrayIsMapParam (_, ArrayReshape cs arr _ new_shape) =       arr `elem` map_param_names         && all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn new_shape)@@ -959,12 +944,10 @@                   BasicOp $ Index arr $ Slice $ whole_dim : slice                 ArrayRearrange _ _ perm ->                   BasicOp $ Rearrange (0 : map (+ 1) perm) arr-                ArrayRotate _ _ rots ->-                  BasicOp $ Rotate (intConst Int64 0 : rots) arr                 ArrayReshape _ _ k new_shape ->                   BasicOp $ Reshape k (Shape [w] <> new_shape) arr                 ArrayCopy {} ->-                  BasicOp $ Copy arr+                  BasicOp $ Replicate mempty $ Var arr                 ArrayVar {} ->                   BasicOp $ SubExp $ Var arr           arr_transformed_t <- lookupType arr_transformed

@@ -381,7 +381,7 @@   pretty (KernelBody _ stms res) =     PP.stack (map pretty (stmsToList stms))       </> "return"-      <+> PP.braces (PP.commasep $ map pretty res)+      <+> PP.braces (PP.commastack $ map pretty res)  certAnnots :: Certs -> [Doc ann] certAnnots cs@@ -1393,7 +1393,7 @@             then do               precopy <- newVName $ baseString (patElemName kpe) <> "_precopy"               index kpe {patElemName = precopy}-              letBindNames [patElemName kpe] $ BasicOp $ Copy precopy+              letBindNames [patElemName kpe] $ BasicOp $ Replicate mempty $ Var precopy             else index kpe           pure             ( kpes'',

@@ -139,6 +139,7 @@     MatchSort (..),     Safety (..),     Lambda (..),+    RetAls (..),      -- * Definitions     Param (..),@@ -355,8 +356,6 @@     --     -- @concat(1, [[1,2], [3, 4]] :| [[[5,6]], [[7, 8]]], 4) = [[1, 2, 5, 6], [3, 4, 7, 8]]@     Concat Int (NonEmpty VName) SubExp-  | -- | Copy the given array.  The result will not alias anything.-    Copy VName   | -- | Manifest an array with dimensions represented in the given     -- order.  The result will not alias anything.     Manifest [Int] VName@@ -367,7 +366,8 @@     -- The t'IntType' indicates the type of the array returned and the     -- offset/stride arguments, but not the length argument.     Iota SubExp SubExp SubExp IntType-  | -- | @replicate([3][2],1) = [[1,1], [1,1], [1,1]]@+  | -- | @replicate([3][2],1) = [[1,1], [1,1], [1,1]]@.  The result+    -- has no aliases.  Copy a value by passing an empty shape.     Replicate Shape SubExp   | -- | Create array of given type and shape, with undefined elements.     Scratch PrimType [SubExp]@@ -378,10 +378,6 @@     -- must be a permutation of @[0,n-1]@, where @n@ is the     -- number of dimensions in the input array.     Rearrange [Int] VName-  | -- | Rotate the dimensions of the input array.  The list of-    -- subexpressions specify how much each dimension is rotated.  The-    -- length of this list must be equal to the rank of the array.-    Rotate [SubExp] VName   | -- | Update an accumulator at the given index with the given value.     -- Consumes the accumulator and produces a new one.     UpdateAcc VName [SubExp] [SubExp]@@ -409,13 +405,30 @@ instance Traversable Case where   traverse f (Case vs b) = Case vs <$> f b +-- | Information about the possible aliases of a function result.+data RetAls = RetAls+  { -- | Which of the parameters may be aliased, numbered from zero.+    paramAls :: [Int],+    -- | Which of the other results may be aliased, numbered from+    -- zero.  This must be a reflexive relation.+    otherAls :: [Int]+  }+  deriving (Eq, Ord, Show)++instance Monoid RetAls where+  mempty = RetAls mempty mempty++instance Semigroup RetAls where+  RetAls pals1 rals1 <> RetAls pals2 rals2 =+    RetAls (pals1 <> pals2) (rals1 <> rals2)+ -- | The root Futhark expression type.  The v'Op' constructor contains -- a rep-specific operation.  Do-loops, branches and function calls -- are special.  Everything else is a simple t'BasicOp'. data Exp rep   = -- | A simple (non-recursive) operation.     BasicOp BasicOp-  | Apply Name [(SubExp, Diet)] [RetType rep] (Safety, SrcLoc, [SrcLoc])+  | Apply Name [(SubExp, Diet)] [(RetType rep, RetAls)] (Safety, SrcLoc, [SrcLoc])   | -- | A match statement picks a branch by comparing the given     -- subexpressions (called the /scrutinee/) with the pattern in     -- each of the cases.  If none of the cases match, the /default@@ -509,7 +522,7 @@     funDefEntryPoint :: Maybe EntryPoint,     funDefAttrs :: Attrs,     funDefName :: Name,-    funDefRetType :: [RetType rep],+    funDefRetType :: [(RetType rep, RetAls)],     funDefParams :: [FParam rep],     funDefBody :: Body rep   }

@@ -12,7 +12,6 @@     -- * Types     Commutativity (..),     Uniqueness (..),-    NoUniqueness (..),     ShapeBase (..),     Shape,     stripDims,@@ -221,16 +220,6 @@ -- | A string representing a specific non-default memory space. type SpaceId = String --- | A fancier name for @()@ - encodes no uniqueness information.-data NoUniqueness = NoUniqueness-  deriving (Eq, Ord, Show)--instance Semigroup NoUniqueness where-  NoUniqueness <> NoUniqueness = NoUniqueness--instance Monoid NoUniqueness where-  mempty = NoUniqueness- -- | The type of a value.  When comparing types for equality with -- '==', shapes must match. data TypeBase shape u@@ -248,7 +237,13 @@   bitraverse _ _ (Mem s) = pure $ Mem s  instance Functor (TypeBase shape) where-  fmap = second+  fmap = fmapDefault++instance Foldable (TypeBase shape) where+  foldMap = foldMapDefault++instance Traversable (TypeBase shape) where+  traverse = bitraverse pure  instance Bifunctor TypeBase where   bimap = bimapDefault

@@ -114,7 +114,7 @@ mapExpM tv (Apply fname args ret loc) = do   args' <- forM args $ \(arg, d) ->     (,) <$> mapOnSubExp tv arg <*> pure d-  Apply fname args' <$> mapM (mapOnRetType tv) ret <*> pure loc+  Apply fname args' <$> mapM (bitraverse (mapOnRetType tv) pure) ret <*> pure loc mapExpM tv (BasicOp (Index arr slice)) =   BasicOp     <$> ( Index@@ -155,15 +155,11 @@         ) mapExpM tv (BasicOp (Rearrange perm e)) =   BasicOp <$> (Rearrange perm <$> mapOnVName tv e)-mapExpM tv (BasicOp (Rotate es e)) =-  BasicOp <$> (Rotate <$> mapM (mapOnSubExp tv) es <*> mapOnVName tv e) mapExpM tv (BasicOp (Concat i (x :| ys) size)) = do   x' <- mapOnVName tv x   ys' <- mapM (mapOnVName tv) ys   size' <- mapOnSubExp tv size   pure $ BasicOp $ Concat i (x' :| ys') size'-mapExpM tv (BasicOp (Copy e)) =-  BasicOp <$> (Copy <$> mapOnVName tv e) mapExpM tv (BasicOp (Manifest perm e)) =   BasicOp <$> (Manifest perm <$> mapOnVName tv e) mapExpM tv (BasicOp (Assert e msg loc)) =@@ -308,8 +304,9 @@   mapM_ (walkOnBody tv mempty . caseBody) cases   walkOnBody tv mempty defbody   mapM_ (walkOnBranchType tv) ts-walkExpM tv (Apply _ args ret _) =-  mapM_ (walkOnSubExp tv . fst) args >> mapM_ (walkOnRetType tv) ret+walkExpM tv (Apply _ args ret _) = do+  mapM_ (walkOnSubExp tv . fst) args+  mapM_ (walkOnRetType tv . fst) ret walkExpM tv (BasicOp (Index arr slice)) =   walkOnVName tv arr >> traverse_ (walkOnSubExp tv) slice walkExpM tv (BasicOp (Update _ arr slice se)) =@@ -332,12 +329,8 @@   mapM_ (walkOnSubExp tv) shape >> walkOnVName tv arrexp walkExpM tv (BasicOp (Rearrange _ e)) =   walkOnVName tv e-walkExpM tv (BasicOp (Rotate es e)) =-  mapM_ (walkOnSubExp tv) es >> walkOnVName tv e walkExpM tv (BasicOp (Concat _ (x :| ys) size)) =   walkOnVName tv x >> mapM_ (walkOnVName tv) ys >> walkOnSubExp tv size-walkExpM tv (BasicOp (Copy e)) =-  walkOnVName tv e walkExpM tv (BasicOp (Manifest _ e)) =   walkOnVName tv e walkExpM tv (BasicOp (Assert e msg _)) =

@@ -46,11 +46,11 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Control.Parallel.Strategies+import Data.Bifunctor (first) import Data.List (find, intercalate, isPrefixOf, sort) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as M import Data.Maybe-import Data.Set qualified as S import Data.Text qualified as T import Futhark.Analysis.Alias import Futhark.Analysis.PrimExp@@ -189,7 +189,7 @@  -- | A tuple of a return type and a list of parameters, possibly -- named.-type FunBinding rep = ([RetType (Aliases rep)], [FParam (Aliases rep)])+type FunBinding rep = ([(RetType (Aliases rep), RetAls)], [FParam (Aliases rep)])  type VarBinding rep = NameInfo (Aliases rep) @@ -439,18 +439,18 @@   TypeM rep a binding stms = check . local (`bindVars` stms)   where-    bindVars = M.foldlWithKey' bindVar+    bindVars orig_env = M.foldlWithKey' (bindVar orig_env) orig_env     boundnames = M.keys stms -    bindVar env name (LetName (AliasDec als, dec)) =+    bindVar orig_env env name (LetName (AliasDec als, dec)) =       let als'             | primType (typeOf dec) = mempty-            | otherwise = expandAliases als env+            | otherwise = expandAliases als orig_env        in env             { envVtable =                 M.insert name (LetName (AliasDec als', dec)) $ envVtable env             }-    bindVar env name dec =+    bindVar _ env name dec =       env {envVtable = M.insert name dec $ envVtable env}      -- Check whether the bound variables have been used correctly@@ -488,18 +488,18 @@   Checkable rep =>   Name ->   [SubExp] ->-  TypeM rep ([RetType rep], [DeclType])+  TypeM rep ([(RetType rep, RetAls)], [DeclType]) lookupFun fname args = do   stm <- asks $ M.lookup fname . envFtable   case stm of     Nothing -> bad $ UnknownFunctionError fname     Just (ftype, params) -> do       argts <- mapM subExpType args-      case applyRetType ftype params $ zip args argts of+      case applyRetType (map fst ftype) params $ zip args argts of         Nothing ->           bad $ ParameterMismatch (Just fname) (map paramType params) argts         Just rt ->-          pure (rt, map paramDeclType params)+          pure (zip rt $ map snd ftype, map paramDeclType params)  -- | @checkAnnotation loc s t1 t2@ checks if @t2@ is equal to -- @t1@.  If not, a 'BadAnnotation' is raised.@@ -610,7 +610,7 @@   where     addBuiltin (fname, (t, ts)) = do       ps <- mapM (primFParam name) ts-      pure (fname, ([primRetType t], ps))+      pure (fname, ([(primRetType t, RetAls mempty mempty)], ps))     name = VName (nameFromString "x") 0  checkFun ::@@ -621,13 +621,13 @@   context ("In function " <> nameToText fname)     $ checkFun'       ( fname,-        map declExtTypeOf rettype,+        map (first declExtTypeOf) rettype,         funParamsToNameInfos params       )       (Just consumable)     $ do       checkFunParams params-      checkRetType rettype+      checkRetType $ map fst rettype       context "When checking function body" $ checkFunBody rettype body   where     consumable =@@ -662,59 +662,72 @@   context ("In lambda parameter " <> prettyText param) $     checkLParamDec (paramName param) (paramDec param) +checkNoDuplicateParams :: Name -> [VName] -> TypeM rep ()+checkNoDuplicateParams fname = foldM_ expand []+  where+    expand seen pname+      | Just _ <- find (== pname) seen =+          bad $ DupParamError fname pname+      | otherwise =+          pure $ pname : seen+ checkFun' ::   Checkable rep =>   ( Name,-    [DeclExtType],+    [(DeclExtType, RetAls)],     [(VName, NameInfo (Aliases rep))]   ) ->   Maybe [(VName, Names)] ->   TypeM rep [Names] ->   TypeM rep () checkFun' (fname, rettype, params) consumable check = do-  checkNoDuplicateParams+  checkNoDuplicateParams fname param_names   binding (M.fromList params) $     maybe id consumeOnlyParams consumable $ do       body_aliases <- check-      scope <- askScope-      let isArray = maybe False ((> 0) . arrayRank . typeOf) . (`M.lookup` scope)       context         ( "When checking the body aliases: "             <> prettyText (map namesToList body_aliases)         )-        $ checkReturnAlias-        $ map (namesFromList . filter isArray . namesToList) body_aliases+        $ checkReturnAlias body_aliases   where     param_names = map fst params -    checkNoDuplicateParams = foldM_ expand [] param_names+    isParam = (`elem` param_names) -    expand seen pname-      | Just _ <- find (== pname) seen =-          bad $ DupParamError fname pname-      | otherwise =-          pure $ pname : seen-    checkReturnAlias =-      foldM_ checkReturnAlias' mempty . returnAliasing rettype+    unique_names = namesFromList $ do+      (v, FParamName t) <- params+      guard $ unique $ declTypeOf t+      pure v -    checkReturnAlias' seen (Unique, names)-      | any (`S.member` S.map fst seen) $ namesToList names =-          bad $ UniqueReturnAliased fname-      | otherwise = do-          consume names-          pure $ seen <> tag Unique names-    checkReturnAlias' seen (Nonunique, names)-      | any (`S.member` seen) $ tag Unique names =-          bad $ UniqueReturnAliased fname-      | otherwise = pure $ seen <> tag Nonunique names+    allowedArgAliases pals =+      namesFromList (map (param_names !!) pals) <> unique_names -    tag u = S.fromList . map (,u) . namesToList+    checkReturnAlias retals = zipWithM_ checkRet (zip [(0 :: Int) ..] rettype) retals+      where+        comrades = zip3 [0 ..] retals $ map (otherAls . snd) rettype -    returnAliasing expected got =-      reverse $-        zip (reverse (map uniqueness expected) ++ repeat Nonunique) $-          reverse got+        checkRet (i, (Array {}, RetAls pals rals)) als+          | als'' <- filter isParam $ namesToList als',+            not $ null als'' =+              bad . TypeError . T.unlines $+                [ T.unwords ["Result", prettyText i, "aliases", prettyText als''],+                  T.unwords ["but is only allowed to alias arguments", prettyText allowed_args]+                ]+          | ((j, _, _) : _) <- filter (isProblem i als' rals) comrades =+              bad . TypeError . T.unlines $+                [ T.unwords ["Results", prettyText i, "and", prettyText j, "alias each other"],+                  T.unwords ["but result", prettyText i, "only allowed to alias results", prettyText rals],+                  prettyText retals+                ]+          where+            allowed_args = allowedArgAliases pals+            als' = als `namesSubtract` allowed_args+        checkRet _ _ = pure () +        isProblem i als rals (j, jals, j_rals) =+          i /= j && j `notElem` rals && i `notElem` j_rals && namesIntersect als jals+ checkSubExp :: Checkable rep => SubExp -> TypeM rep Type checkSubExp (Constant val) =   pure $ Prim $ primValueType val@@ -753,7 +766,7 @@  checkFunBody ::   Checkable rep =>-  [RetType rep] ->+  [(RetType rep, RetAls)] ->   Body (Aliases rep) ->   TypeM rep [Names] checkFunBody rt (Body (_, rep) stms res) = do@@ -761,23 +774,17 @@   checkStms stms $ do     context "When checking body result" $ checkResult res     context "When matching declared return type to result of body" $-      matchReturnType rt res-    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res-  where-    bound_here = namesFromList $ M.keys $ scopeOf stms+      matchReturnType (map fst rt) res+    mapM (subExpAliasesM . resSubExp) res  checkLambdaBody ::   Checkable rep =>   [Type] ->   Body (Aliases rep) ->-  TypeM rep [Names]+  TypeM rep () checkLambdaBody ret (Body (_, rep) stms res) = do   checkBodyDec rep-  checkStms stms $ do-    checkLambdaResult ret res-    map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res-  where-    bound_here = namesFromList $ M.keys $ scopeOf stms+  checkStms stms $ checkLambdaResult ret res  checkLambdaResult ::   Checkable rep =>@@ -909,18 +916,6 @@     bad $       PermutationError perm rank $         Just arr-checkBasicOp (Rotate rots arr) = do-  arrt <- lookupType arr-  let rank = arrayRank arrt-  mapM_ (require [Prim int64]) rots-  when (length rots /= rank) $-    bad $-      TypeError $-        "Cannot rotate "-          <> prettyText (length rots)-          <> " dimensions of "-          <> prettyText rank-          <> "-dimensional array." checkBasicOp (Concat i (arr1exp :| arr2exps) ressize) = do   arr1_dims <- shapeDims . fst <$> checkArrIdent arr1exp   arr2s_dims <- map (shapeDims . fst) <$> mapM checkArrIdent arr2exps@@ -928,8 +923,6 @@     bad $       TypeError "Types of arguments to concat do not match."   require [Prim int64] ressize-checkBasicOp (Copy e) =-  void $ checkArrIdent e checkBasicOp (Manifest perm arr) =   checkBasicOp $ Rearrange perm arr -- Basically same thing! checkBasicOp (Assert e (ErrorMsg parts) _) = do@@ -986,6 +979,10 @@           (staticShapes rettype')           (staticShapes bodyt) +allowAllAliases :: Int -> Int -> RetAls+allowAllAliases n m =+  RetAls [0 .. n - 1] [0 .. m - 1]+ checkExp ::   Checkable rep =>   Exp (Aliases rep) ->@@ -1016,9 +1013,9 @@   when (rettype_derived /= rettype_annot) $     bad . TypeError . docText $       "Expected apply result type:"-        </> indent 2 (pretty rettype_derived)+        </> indent 2 (pretty $ map fst rettype_derived)         </> "But annotation is:"-        </> indent 2 (pretty rettype_annot)+        </> indent 2 (pretty $ map fst rettype_annot)   consumeArgs paramtypes argflows checkExp (DoLoop merge form loopbody) = do   let (mergepat, mergeexps) = unzip merge@@ -1040,7 +1037,7 @@     context "Inside the loop body"       $ checkFun'         ( nameFromString "<loop body>",-          staticShapes rettype,+          map (,allowAllAliases (length merge) (length merge)) (staticShapes rettype),           funParamsToNameInfos mergepat         )         (Just consumable)@@ -1281,23 +1278,9 @@   context "When checking expression annotation" $ checkExpDec dec   context ("When matching\n" <> message "  " pat <> "\nwith\n" <> message "  " e) $     matchPat pat e-  binding (maybeWithoutAliases $ scopeOf stm) $ do+  binding (scopeOf stm) $ do     mapM_ checkPatElem (patElems $ removePatAliases pat)     m-  where-    -- FIXME: this is wrong.  However, the core language type system-    -- is not strong enough to fully capture the aliases we want (see-    -- issue #803).  Since we eventually inline everything anyway, and-    -- our intra-procedural alias analysis is much simpler and-    -- correct, I could not justify spending time on improving the-    -- inter-procedural alias analysis.  If we ever stop inlining-    -- everything, probably we need to go back and refine this.-    maybeWithoutAliases =-      case stmExp stm of-        Apply {} -> M.map withoutAliases-        _ -> id-    withoutAliases (LetName (_, ldec)) = LetName (mempty, ldec)-    withoutAliases info = info  matchExtPat ::   Checkable rep =>@@ -1429,10 +1412,9 @@               else Nothing           params' =             [(paramName param, LParamName $ paramDec param) | param <- params]-      checkFun'-        (fname, staticShapes $ map (`toDecl` Nonunique) rettype, params')-        consumable-        $ do+      checkNoDuplicateParams fname $ map paramName params+      binding (M.fromList params') $+        maybe id consumeOnlyParams consumable $ do           checkLambdaParams params           mapM_ checkType rettype           checkLambdaBody rettype body

@@ -48,9 +48,11 @@ import Futhark.Internalise.Defunctorise as Defunctorise import Futhark.Internalise.Entry (visibleTypes) import Futhark.Internalise.Exps qualified as Exps+import Futhark.Internalise.FullNormalise qualified as FullNormalise import Futhark.Internalise.LiftLambdas as LiftLambdas import Futhark.Internalise.Monad as I import Futhark.Internalise.Monomorphise as Monomorphise+import Futhark.Internalise.ReplaceRecords as ReplaceRecords import Futhark.Util.Log import Language.Futhark.Semantic (Imports) @@ -64,14 +66,18 @@ internaliseProg config prog = do   maybeLog "Defunctorising"   prog_decs <- Defunctorise.transformProg prog+  maybeLog "Full Normalising"+  prog_decs' <- FullNormalise.transformProg prog_decs   maybeLog "Monomorphising"-  prog_decs' <- Monomorphise.transformProg prog_decs+  prog_decs'' <- Monomorphise.transformProg prog_decs'+  maybeLog "Replacing records"+  prog_decs''' <- ReplaceRecords.transformProg prog_decs''   maybeLog "Lifting lambdas"-  prog_decs'' <- LiftLambdas.transformProg prog_decs'+  prog_decs'''' <- LiftLambdas.transformProg prog_decs'''   maybeLog "Defunctionalising"-  prog_decs''' <- Defunctionalise.transformProg prog_decs''+  prog_decs''''' <- Defunctionalise.transformProg prog_decs''''   maybeLog "Converting to core IR"-  Exps.transformProg (futharkSafe config) (visibleTypes prog) prog_decs'''+  Exps.transformProg (futharkSafe config) (visibleTypes prog) prog_decs'''''   where     verbose = fst (futharkVerbose config) > NotVerbose     maybeLog s

@@ -12,8 +12,10 @@ where  import Control.Monad+import Control.Monad.Free (Free (..)) import Control.Monad.Reader import Data.Bifunctor+import Data.Foldable (toList) import Data.Map.Strict qualified as M import Data.Maybe import Futhark.IR.SOACS qualified as I@@ -33,44 +35,64 @@ internaliseAttrs :: [E.AttrInfo VName] -> InternaliseM I.Attrs internaliseAttrs = fmap (mconcat . map I.oneAttr) . mapM internaliseAttr +treeLike :: Tree a -> [b] -> Tree b+treeLike (Pure _) [b] = Pure b+treeLike (Pure _) _ = error "treeLike: invalid input"+treeLike (Free ls) bs = Free $ zipWith treeLike ls (chunks (map length ls) bs)+ bindingFParams ::   [E.TypeParam] ->-  [E.Pat] ->-  ([I.FParam I.SOACS] -> [[I.FParam I.SOACS]] -> InternaliseM a) ->+  [E.Pat E.ParamType] ->+  ([I.FParam I.SOACS] -> [[Tree (I.FParam I.SOACS)]] -> InternaliseM a) ->   InternaliseM a bindingFParams tparams params m = do   flattened_params <- mapM flattenPat params   let params_idents = concat flattened_params   params_ts <-     internaliseParamTypes $-      map (flip E.setAliases () . E.unInfo . E.identType . fst) params_idents+      map (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 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)-    I.localScope (I.scopeOfFParams $ catMaybes certparams ++ shape_params ++ valueparams') $-      substitutingVars shape_subst $-        m (catMaybes certparams ++ shape_params) $-          chunks num_param_ts valueparams'+  bindingFlatPat params_idents (concatMap (concatMap toList) params_ts) $ \valueparams -> do+    let (certparams, valueparams') =+          first concat $ unzip $ map fixAccParams valueparams+        all_params = certparams ++ shape_params ++ concat valueparams'+    I.localScope (I.scopeOfFParams all_params) $+      substitutingVars shape_subst $ do+        let values_grouped_by_params = chunks num_param_idents valueparams'+            types_grouped_by_params = chunks num_param_idents params_ts++        m (certparams ++ shape_params) $+          zipWith chunkValues types_grouped_by_params values_grouped_by_params   where+    fixAccParams ps =+      first catMaybes $ unzip $ map fixAccParam ps     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) +    chunkValues ::+      [[Tree (I.TypeBase I.Shape Uniqueness)]] ->+      [[I.FParam I.SOACS]] ->+      [Tree (I.FParam I.SOACS)]+    chunkValues tss vss =+      concat $ zipWith f tss vss+      where+        f ts vs = zipWith treeLike ts (chunks (map length ts) vs)+ bindingLoopParams ::   [E.TypeParam] ->-  E.Pat ->+  E.Pat E.ParamType ->   [I.Type] ->   ([I.FParam I.SOACS] -> [I.FParam I.SOACS] -> InternaliseM a) ->   InternaliseM a bindingLoopParams tparams pat ts m = do   pat_idents <- flattenPat pat-  pat_ts <- internaliseLoopParamType (E.patternStructType pat) ts+  pat_ts <- internaliseLoopParamType (E.patternType pat) ts    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]@@ -78,11 +100,10 @@   bindingFlatPat pat_idents pat_ts $ \valueparams ->     I.localScope (I.scopeOfFParams $ shape_params ++ concat valueparams) $       substitutingVars shape_subst $-        m shape_params $-          concat valueparams+        m shape_params (concat valueparams)  bindingLambdaParams ::-  [E.Pat] ->+  [E.Pat E.ParamType] ->   [I.Type] ->   ([I.LParam I.SOACS] -> InternaliseM a) ->   InternaliseM a@@ -90,13 +111,16 @@   params_idents <- concat <$> mapM flattenPat params    bindingFlatPat params_idents ts $ \params' ->-    I.localScope (I.scopeOfLParams $ concat params') $ m $ concat params'+    I.localScope (I.scopeOfLParams $ concat params') $+      m (concat params') +type Params t = [I.Param t]+ processFlatPat ::   Show t =>-  [(E.Ident, [E.AttrInfo VName])] ->+  [(E.Ident ParamType, [E.AttrInfo VName])] ->   [t] ->-  InternaliseM ([[I.Param t]], VarSubsts)+  InternaliseM ([Params t], VarSubsts) processFlatPat x y = processFlatPat' [] x y   where     processFlatPat' pat [] _ = do@@ -105,7 +129,10 @@     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+      processFlatPat'+        ((ps, (E.identName p, map (I.Var . I.paramName) ps)) : pat)+        rest+        rest_ts      handleMapping _ ts [] =       ([], ts)@@ -113,9 +140,9 @@       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)+      error $ "handleMapping: insufficient identifiers in pattern.\n" ++ show (x, y) -    internaliseBindee :: E.Ident -> InternaliseM [VName]+    internaliseBindee :: E.Ident E.ParamType -> InternaliseM [VName]     internaliseBindee bindee = do       let name = E.identName bindee       case internalisedTypeSize $ E.unInfo $ E.identType bindee of@@ -124,9 +151,9 @@  bindingFlatPat ::   Show t =>-  [(E.Ident, [E.AttrInfo VName])] ->+  [(E.Ident E.ParamType, [E.AttrInfo VName])] ->   [t] ->-  ([[I.Param t]] -> InternaliseM a) ->+  ([Params t] -> InternaliseM a) ->   InternaliseM a bindingFlatPat idents ts m = do   (ps, substs) <- processFlatPat idents ts@@ -134,7 +161,7 @@     m ps  -- | Flatten a pattern.  Returns a list of identifiers.-flattenPat :: MonadFreshNames m => E.Pat -> m [(E.Ident, [E.AttrInfo VName])]+flattenPat :: MonadFreshNames m => E.Pat (TypeBase Size u) -> m [(E.Ident (TypeBase Size u), [E.AttrInfo VName])] flattenPat = flattenPat'   where     flattenPat' (E.PatParens p _) =@@ -162,7 +189,7 @@       concat <$> mapM flattenPat' ps  stmPat ::-  E.Pat ->+  E.Pat E.ParamType ->   [I.Type] ->   ([VName] -> InternaliseM a) ->   InternaliseM a

@@ -15,7 +15,7 @@ import Data.Set qualified as S import Futhark.IR.Pretty () import Futhark.MonadFreshNames-import Futhark.Util (mapAccumLM)+import Futhark.Util (mapAccumLM, nubOrd) import Language.Futhark import Language.Futhark.Traversals import Language.Futhark.TypeChecker.Types (Subst (..), applySubst)@@ -23,30 +23,30 @@ -- | A static value stores additional information about the result of -- defunctionalization of an expression, aside from the residual expression. data StaticVal-  = Dynamic PatType+  = Dynamic ParamType   | -- | The Env is the lexical closure of the lambda.-    LambdaSV Pat StructRetType Exp Env+    LambdaSV (Pat ParamType) ResRetType Exp Env   | RecordSV [(Name, StaticVal)]   | -- | The constructor that is actually present, plus     -- the others that are not.-    SumSV Name [StaticVal] [(Name, [PatType])]+    SumSV Name [StaticVal] [(Name, [ParamType])]   | -- | The pair is the StaticVal and residual expression of this     -- function as a whole, while the second StaticVal is its     -- body. (Don't trust this too much, my understanding may have     -- holes.)     DynamicFun (Exp, StaticVal) StaticVal   | IntrinsicSV-  | HoleSV PatType SrcLoc+  | HoleSV StructType SrcLoc   deriving (Show) --- | The type is Just if this is a polymorphic binding that must be--- instantiated.-data Binding = Binding (Maybe ([VName], StructType)) StaticVal+data Binding = Binding+  { -- | Just if this is a polymorphic binding that must be+    -- instantiated.+    bindingType :: Maybe ([VName], StructType),+    bindingSV :: StaticVal+  }   deriving (Show) -bindingSV :: Binding -> StaticVal-bindingSV (Binding _ sv) = sv- -- | Environment mapping variable names to their associated static -- value. type Env = M.Map VName Binding@@ -72,11 +72,11 @@   TypeBase Size als replaceTypeSizes substs = first onDim   where-    onDim (NamedSize v) =+    onDim (Var v typ loc) =       case M.lookup (qualLeaf v) substs of-        Just (SubstNamed v') -> NamedSize v'-        Just (SubstConst d) -> ConstSize d-        Nothing -> NamedSize v+        Just (SubstNamed v') -> Var v' typ loc+        Just (SubstConst d) -> sizeFromInteger (toInteger d) loc+        Nothing -> Var v typ loc     onDim d = d  replaceStaticValSizes ::@@ -92,7 +92,7 @@             foldl' (flip M.delete) orig_substs $               S.fromList (M.keys closure_env)        in LambdaSV-            (onAST substs param)+            (fmap (replaceTypeSizes substs) param)             (RetType t_dims (replaceTypeSizes substs t))             (onExp substs e)             (onEnv orig_substs closure_env) -- intentional@@ -112,9 +112,10 @@       HoleSV t loc   where     tv substs =-      identityMapper-        { mapOnPatType = pure . replaceTypeSizes substs,-          mapOnStructType = pure . replaceTypeSizes substs,+      ASTMapper+        { mapOnStructType = pure . replaceTypeSizes substs,+          mapOnParamType = pure . replaceTypeSizes substs,+          mapOnResRetType = pure,           mapOnExp = pure . onExp substs,           mapOnName = pure . onName substs         }@@ -132,47 +133,16 @@           Literal (SignedValue (Int64Value (fromIntegral d))) loc         Nothing ->           Var v (replaceTypeSizes substs <$> t) loc-    onExp substs (AppExp (Coerce e te loc) (Info (AppRes t ext))) =-      AppExp (Coerce (onExp substs e) te' loc) (Info (AppRes (replaceTypeSizes substs t) ext))-      where-        te' = onTypeExp substs te-    onExp substs (Lambda params e ret (Info (als, RetType t_dims t)) loc) =+    onExp substs (Coerce e te t loc) =+      Coerce (onExp substs e) te (replaceTypeSizes substs <$> t) loc+    onExp substs (Lambda params e ret (Info (RetType t_dims t)) loc) =       Lambda-        (map (onAST substs) params)+        (map (fmap $ replaceTypeSizes substs) params)         (onExp substs e)         ret-        (Info (als, RetType t_dims (replaceTypeSizes substs t)))+        (Info (RetType t_dims (replaceTypeSizes substs t)))         loc-    onExp substs e = onAST substs e--    onTypeExpDim substs (SizeExp e loc) = SizeExp (onExp substs e) loc-    onTypeExpDim _ (SizeExpAny loc) = SizeExpAny loc--    onTypeArgExp substs (TypeArgExpSize d) =-      TypeArgExpSize (onTypeExpDim substs d)-    onTypeArgExp substs (TypeArgExpType te) =-      TypeArgExpType (onTypeExp substs te)--    onTypeExp substs (TEArray d te loc) =-      TEArray (onTypeExpDim substs d) (onTypeExp substs te) loc-    onTypeExp substs (TEUnique t loc) =-      TEUnique (onTypeExp substs t) loc-    onTypeExp substs (TEApply t1 t2 loc) =-      TEApply (onTypeExp substs t1) (onTypeArgExp substs t2) loc-    onTypeExp substs (TEArrow p t1 t2 loc) =-      TEArrow p (onTypeExp substs t1) (onTypeExp substs t2) loc-    onTypeExp substs (TETuple ts loc) =-      TETuple (map (onTypeExp substs) ts) loc-    onTypeExp substs (TERecord ts loc) =-      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 substs (TEParens te loc) =-      TEParens (onTypeExp substs te) loc-    onTypeExp _ (TEVar v loc) =-      TEVar v loc+    onExp substs e = runIdentity $ astMap (tv substs) e      onEnv substs =       M.fromList@@ -184,35 +154,29 @@         (second (replaceTypeSizes substs) <$> t)         (replaceStaticValSizes globals substs bsv) -    onAST :: ASTMappable x => M.Map VName SizeSubst -> x -> x-    onAST substs = runIdentity . astMap (tv substs)- -- | Returns the defunctionalization environment restricted--- to the given set of variable names and types.+-- to the given set of variable names. restrictEnvTo :: FV -> DefM Env-restrictEnvTo (FV m) = asks restrict+restrictEnvTo fv = asks restrict   where     restrict (globals, env) = M.mapMaybeWithKey keep env       where         keep k (Binding t sv) = do-          guard $ not $ k `S.member` globals-          u <- uniqueness <$> M.lookup k m-          Just $ Binding t $ restrict' u sv-    restrict' Nonunique (Dynamic t) =-      Dynamic $ t `setUniqueness` Nonunique-    restrict' _ (Dynamic t) =+          guard $ not (k `S.member` globals) && S.member k (fvVars fv)+          Just $ Binding t $ restrict' sv+    restrict' (Dynamic t) =       Dynamic t-    restrict' u (LambdaSV pat t e env) =-      LambdaSV pat t e $ M.map (restrict'' u) env-    restrict' u (RecordSV fields) =-      RecordSV $ map (fmap $ restrict' u) fields-    restrict' u (SumSV c svs fields) =-      SumSV c (map (restrict' u) svs) fields-    restrict' u (DynamicFun (e, sv1) sv2) =-      DynamicFun (e, restrict' u sv1) $ restrict' u sv2-    restrict' _ IntrinsicSV = IntrinsicSV-    restrict' _ (HoleSV t loc) = HoleSV t loc-    restrict'' u (Binding t sv) = Binding t $ restrict' u sv+    restrict' (LambdaSV pat t e env) =+      LambdaSV pat t e $ M.map restrict'' env+    restrict' (RecordSV fields) =+      RecordSV $ map (fmap restrict') fields+    restrict' (SumSV c svs fields) =+      SumSV c (map restrict' svs) fields+    restrict' (DynamicFun (e, sv1) sv2) =+      DynamicFun (e, restrict' sv1) $ restrict' sv2+    restrict' IntrinsicSV = IntrinsicSV+    restrict' (HoleSV t loc) = HoleSV t loc+    restrict'' (Binding t sv) = Binding t $ restrict' sv  -- | Defunctionalization monad.  The Reader environment tracks both -- the current Env as well as the set of globally defined dynamic@@ -242,6 +206,36 @@ addValBind :: ValBind -> DefM () addValBind vb = modify $ first (vb :) +-- | Create a new top-level value declaration with the given function name,+-- return type, list of parameters, and body expression.+liftValDec :: VName -> ResRetType -> [VName] -> [Pat ParamType] -> 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+    -- forget those return sizes that we forgot to propagate along+    -- the way.  Hopefully the internaliser is conservative and+    -- will insert reshapes...+    bound_here = S.fromList $ dims <> foldMap patNames pats+    mkExt v+      | not $ v `S.member` bound_here = Just v+    mkExt _ = Nothing+    rettype_st = RetType (mapMaybe mkExt (S.toList $ fvVars $ freeInType ret) ++ ret_dims) ret++    dec =+      ValBind+        { valBindEntryPoint = Nothing,+          valBindName = fname,+          valBindRetDecl = Nothing,+          valBindRetType = Info rettype_st,+          valBindTypeParams = dims',+          valBindParams = pats,+          valBindBody = body,+          valBindDoc = Nothing,+          valBindAttrs = mempty,+          valBindLocation = mempty+        }+ -- | Looks up the associated static value for a given name in the environment. lookupVar :: StructType -> VName -> DefM StaticVal lookupVar t x = do@@ -265,21 +259,21 @@ arraySizes (Scalar Arrow {}) = mempty arraySizes (Scalar (Record fields)) = foldMap arraySizes fields arraySizes (Scalar (Sum cs)) = foldMap (foldMap arraySizes) cs-arraySizes (Scalar (TypeVar _ _ _ targs)) =+arraySizes (Scalar (TypeVar _ _ targs)) =   mconcat $ map f targs   where-    f (TypeArgDim (NamedSize d) _) = S.singleton $ qualLeaf d+    f (TypeArgDim (Var d _ _)) = S.singleton $ qualLeaf d     f TypeArgDim {} = mempty-    f (TypeArgType t _) = arraySizes t+    f (TypeArgType t) = arraySizes t arraySizes (Scalar Prim {}) = mempty-arraySizes (Array _ _ shape t) =+arraySizes (Array _ shape t) =   arraySizes (Scalar t) <> foldMap dimName (shapeDims shape)   where     dimName :: Size -> S.Set VName-    dimName (NamedSize qn) = S.singleton $ qualLeaf qn+    dimName (Var qn _ _) = S.singleton $ qualLeaf qn     dimName _ = mempty -patternArraySizes :: Pat -> S.Set VName+patternArraySizes :: Pat ParamType -> S.Set VName patternArraySizes = arraySizes . patternStructType  data SizeSubst@@ -294,14 +288,14 @@   M.Map VName SizeSubst dimMapping t1 t2 = execState (matchDims f t1 t2) mempty   where-    f bound d1 (NamedSize d2)+    f bound d1 (Var d2 _ _)       | qualLeaf d2 `elem` bound = pure d1-    f _ (NamedSize d1) (NamedSize d2) = do+    f _ (Var d1 typ loc) (Var d2 _ _) = do       modify $ M.insert (qualLeaf d1) $ SubstNamed d2-      pure $ NamedSize d1-    f _ (NamedSize d1) (ConstSize d2) = do-      modify $ M.insert (qualLeaf d1) $ SubstConst d2-      pure $ NamedSize d1+      pure $ Var d1 typ loc+    f _ (Var d1 typ loc) (IntLit d2 _ _) = do+      modify $ M.insert (qualLeaf d1) $ SubstConst $ fromInteger d2+      pure $ Var d1 typ loc     f _ d _ = pure d  dimMapping' ::@@ -328,11 +322,52 @@ sizesToRename (SumSV _ svs _) =   foldMap sizesToRename svs sizesToRename (LambdaSV param _ _ _) =-  freeInPat param-    <> S.map identName (S.filter couldBeSize $ patIdents param)+  -- We used to rename parameters here, but I don't understand why+  -- that was necessary and it caused some problems.+  fvVars (freeInPat param)++-- | Combine the shape information of types as much as possible. The first+-- argument is the orignal type and the second is the type of the transformed+-- expression. This is necessary since the original type may contain additional+-- information (e.g., shape restrictions) from the user given annotation.+combineTypeShapes ::+  (Monoid as) =>+  TypeBase Size as ->+  TypeBase Size as ->+  TypeBase Size as+combineTypeShapes (Scalar (Record ts1)) (Scalar (Record ts2))+  | M.keys ts1 == M.keys ts2 =+      Scalar $+        Record $+          M.map+            (uncurry combineTypeShapes)+            (M.intersectionWith (,) ts1 ts2)+combineTypeShapes (Scalar (Sum cs1)) (Scalar (Sum cs2))+  | M.keys cs1 == M.keys cs2 =+      Scalar $+        Sum $+          M.map+            (uncurry $ zipWith combineTypeShapes)+            (M.intersectionWith (,) cs1 cs2)+combineTypeShapes (Scalar (Arrow als1 p1 d1 a1 (RetType dims1 b1))) (Scalar (Arrow als2 _p2 _d2 a2 (RetType _ b2))) =+  Scalar $+    Arrow+      (als1 <> als2)+      p1+      d1+      (combineTypeShapes a1 a2)+      (RetType dims1 (combineTypeShapes b1 b2))+combineTypeShapes (Scalar (TypeVar u v targs1)) (Scalar (TypeVar _ _ targs2)) =+  Scalar $ TypeVar u v $ zipWith f targs1 targs2   where-    couldBeSize ident =-      unInfo (identType ident) == Scalar (Prim (Signed Int64))+    f (TypeArgType t1) (TypeArgType t2) = TypeArgType (combineTypeShapes t1 t2)+    f targ _ = targ+combineTypeShapes (Array u shape1 et1) (Array _ _shape2 et2) =+  arrayOfWithAliases+    u+    shape1+    (combineTypeShapes (setUniqueness (Scalar et1) u) (setUniqueness (Scalar et2) u))+combineTypeShapes _ t = t  -- When we instantiate a polymorphic StaticVal, we rename all the -- sizes to avoid name conflicts later on.  This is a bit of a hack...@@ -348,7 +383,6 @@   fresh_substs <-     mkSubsts . filter (`S.notMember` globals) . S.toList $       S.fromList dims <> sizesToRename sv-   let dims' = map (onName fresh_substs) dims       isDim k _ = k `elem` dims'       dim_substs =@@ -370,9 +404,9 @@  defuncFun ::   [VName] ->-  [Pat] ->+  [Pat ParamType] ->   Exp ->-  StructRetType ->+  ResRetType ->   SrcLoc ->   DefM (Exp, StaticVal) defuncFun tparams pats e0 ret loc = do@@ -383,22 +417,22 @@         [pat'] -> (pat', ret, e0)         (pat' : pats') ->           ( pat',-            RetType [] $ funType pats' ret,-            Lambda pats' e0 Nothing (Info (mempty, ret)) loc+            RetType [] $ second (const Nonunique) $ funType pats' ret,+            Lambda pats' e0 Nothing (Info ret) loc           )    -- Construct a record literal that closes over the environment of   -- the lambda.  Closed-over 'DynamicFun's are converted to their   -- closure representation.   let used =-        freeInExp (Lambda pats e0 Nothing (Info (mempty, ret)) loc)+        freeInExp (Lambda pats e0 Nothing (Info ret) loc)           `freeWithout` S.fromList tparams   used_env <- restrictEnvTo used    -- The closure parts that are sizes are proactively turned into size   -- parameters.   let sizes_of_arrays =-        foldMap (arraySizes . toStruct . typeFromSV . bindingSV) used_env+        foldMap (arraySizes . structTypeFromSV . bindingSV) used_env           <> patternArraySizes pat       notSize = not . (`S.member` sizes_of_arrays)       (fields, env) =@@ -420,7 +454,7 @@           )     closureFromDynamicFun (vn, Binding _ sv) =       let name = nameFromString $ prettyString vn-          tp' = typeFromSV sv+          tp' = structTypeFromSV sv        in ( RecordFieldExplicit               name               (Var (qualName vn) (Info tp') mempty)@@ -432,13 +466,13 @@ -- the associated static value in the defunctionalization monad. defuncExp :: Exp -> DefM (Exp, StaticVal) defuncExp e@Literal {} =-  pure (e, Dynamic $ typeOf e)+  pure (e, Dynamic $ toParam Observe $ typeOf e) defuncExp e@IntLit {} =-  pure (e, Dynamic $ typeOf e)+  pure (e, Dynamic $ toParam Observe $ typeOf e) defuncExp e@FloatLit {} =-  pure (e, Dynamic $ typeOf e)+  pure (e, Dynamic $ toParam Observe $ typeOf e) defuncExp e@StringLit {} =-  pure (e, Dynamic $ typeOf e)+  pure (e, Dynamic $ toParam Observe $ typeOf e) defuncExp (Parens e loc) = do   (e', sv) <- defuncExp e   pure (Parens e' loc, sv)@@ -470,35 +504,36 @@         -- The field may refer to a functional expression, so we get the         -- type from the static value and not the one from the AST.         _ ->-          let tp = Info $ typeFromSV sv+          let tp = Info $ structTypeFromSV sv            in pure (RecordFieldImplicit vn tp loc', (baseName vn, sv)) defuncExp (ArrayLit es t@(Info t') loc) = do   es' <- mapM defuncExp' es-  pure (ArrayLit es' t loc, Dynamic t')+  pure (ArrayLit es' t loc, Dynamic $ toParam Observe t') defuncExp (AppExp (Range e1 me incl loc) res) = do   e1' <- defuncExp' e1   me' <- mapM defuncExp' me   incl' <- mapM defuncExp' incl   pure     ( AppExp (Range e1' me' incl' loc) res,-      Dynamic $ appResType $ unInfo res+      Dynamic $ toParam Observe $ appResType $ unInfo res     ) defuncExp e@(Var qn (Info t) loc) = do   sv <- lookupVar (toStruct t) (qualLeaf qn)   case sv of-    -- If the variable refers to a dynamic function, we return its closure-    -- representation (i.e., a record expression capturing the free variables-    -- and a 'LambdaSV' static value) instead of the variable itself.-    DynamicFun closure _ -> pure closure+    -- If the variable refers to a dynamic function, we eta-expand it+    -- so that we do not have to duplicate its definition.+    DynamicFun {} -> do+      (params, body, ret) <- etaExpand (RetType [] $ toRes Nonunique t) e+      defuncFun [] params body ret mempty     -- Intrinsic functions used as variables are eta-expanded, so we     -- can get rid of them.     IntrinsicSV -> do-      (pats, body, tp) <- etaExpand (RetType [] (typeOf e)) e-      defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) mempty+      (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique t) e+      defuncExp $ Lambda pats body Nothing (Info tp) mempty     HoleSV _ hole_loc ->       pure (Hole (Info t) hole_loc, sv)     _ ->-      pure (Var qn (Info (typeFromSV sv)) loc, sv)+      pure (Var qn (Info (structTypeFromSV sv)) loc, sv) defuncExp (Hole (Info t) loc) =   pure (Hole (Info t) loc, HoleSV t loc) defuncExp (Ascript e0 tydecl loc)@@ -506,24 +541,23 @@       (e0', sv) <- defuncExp e0       pure (Ascript e0' tydecl loc, sv)   | otherwise = defuncExp e0-defuncExp (AppExp (Coerce e0 tydecl loc) res)+defuncExp (Coerce e0 tydecl t loc)   | orderZero (typeOf e0) = do       (e0', sv) <- defuncExp e0-      pure (AppExp (Coerce e0' tydecl loc) res, sv)+      pure (Coerce e0' tydecl t loc, sv)   | otherwise = defuncExp e0 defuncExp (AppExp (LetPat sizes pat e1 e2 loc) (Info (AppRes t retext))) = do   (e1', sv1) <- defuncExp e1-  let env = alwaysMatchPatSV pat sv1-      pat' = updatePat pat sv1+  let env = alwaysMatchPatSV (fmap (toParam Observe) pat) sv1+      pat' = updatePat (fmap (toParam Observe) pat) sv1   (e2', sv2) <- localEnv env $ defuncExp e2   -- To maintain any sizes going out of scope, we need to compute the   -- old size substitution induced by retext and also apply it to the   -- newly computed body type.   let mapping = dimMapping' (typeOf e2) t-      subst v = fromMaybe v $ M.lookup v mapping-      mapper = identityMapper {mapOnName = pure . subst}-      t' = first (runIdentity . astMap mapper) $ typeOf e2'-  pure (AppExp (LetPat sizes pat' e1' e2' loc) (Info (AppRes t' retext)), sv2)+      subst v = ExpSubst . flip sizeFromName mempty . qualName <$> M.lookup v mapping+      t' = applySubst subst $ typeOf e2'+  pure (AppExp (LetPat sizes (fmap toStruct pat') e1' e2' loc) (Info (AppRes t' retext)), sv2) defuncExp (AppExp (LetFun vn _ _ _) _) =   error $ "defuncExp: Unexpected LetFun: " ++ show vn defuncExp (AppExp (If e1 e2 e3 loc) res) = do@@ -539,7 +573,7 @@ defuncExp (Not e0 loc) = do   (e0', sv) <- defuncExp e0   pure (Not e0' loc, sv)-defuncExp (Lambda pats e0 _ (Info (_, ret)) loc) =+defuncExp (Lambda pats e0 _ (Info ret) loc) =   defuncFun [] pats e0 ret loc -- Operator sections are expected to be converted to lambda-expressions -- by the monomorphizer, so they should no longer occur at this point.@@ -557,7 +591,7 @@       pure (For v e2', envFromIdent v)     ForIn pat2 e2 -> do       e2' <- defuncExp' e2-      pure (ForIn pat2 e2', envFromPat pat2)+      pure (ForIn pat2 e2', envFromPat $ fmap (toParam Observe) pat2)     While e2 -> do       e2' <- localEnv env1 $ defuncExp' e2       pure (While e2', mempty)@@ -565,22 +599,23 @@   pure (AppExp (DoLoop sparams pat e1' form' e3' loc) res, sv)   where     envFromIdent (Ident vn (Info tp) _) =-      M.singleton vn $ Binding Nothing $ Dynamic tp+      M.singleton vn $ Binding Nothing $ Dynamic $ toParam Observe tp defuncExp e@(AppExp BinOp {} _) =   error $ "defuncExp: unexpected binary operator: " ++ prettyString e defuncExp (Project vn e0 tp@(Info tp') loc) = do   (e0', sv0) <- defuncExp e0   case sv0 of     RecordSV svs -> case lookup vn svs of-      Just sv -> pure (Project vn e0' (Info $ typeFromSV sv) loc, sv)+      Just sv -> pure (Project vn e0' (Info $ structTypeFromSV sv) loc, sv)       Nothing -> error "Invalid record projection."-    Dynamic _ -> pure (Project vn e0' tp loc, Dynamic tp')+    Dynamic _ -> pure (Project vn e0' tp loc, Dynamic $ toParam Observe tp')     HoleSV _ hloc -> pure (Project vn e0' tp loc, HoleSV tp' hloc)     _ -> error $ "Projection of an expression with static value " ++ show sv0 defuncExp (AppExp (LetWith id1 id2 idxs e1 body loc) res) = do   e1' <- defuncExp' e1   idxs' <- mapM defuncDimIndex idxs-  let id1_binding = Binding Nothing $ Dynamic $ unInfo $ identType id1+  let id1_binding =+        Binding Nothing $ Dynamic $ toParam Observe $ unInfo $ identType id1   (body', sv) <-     localEnv (M.singleton (identName id1) id1_binding) $       defuncExp body@@ -590,7 +625,7 @@   idxs' <- mapM defuncDimIndex idxs   pure     ( AppExp (Index e0' idxs' loc) res,-      Dynamic $ typeOf expr+      Dynamic $ toParam Observe $ typeOf expr     ) defuncExp (Update e1 idxs e2 loc) = do   (e1', sv) <- defuncExp e1@@ -606,7 +641,7 @@   (e2', sv2) <- defuncExp e2   let sv = staticField sv1 sv2 fs   pure-    ( RecordUpdate e1' fs e2' (Info $ typeFromSV sv1) loc,+    ( RecordUpdate e1' fs e2' (Info $ structTypeFromSV sv1) loc,       sv     )   where@@ -628,15 +663,15 @@   let sv =         SumSV name svs $           M.toList $-            name `M.delete` M.map (map defuncType) all_fs-      sum_t' = combineTypeShapes sum_t (typeFromSV sv)+            name `M.delete` M.map (map (toParam Observe . defuncType)) all_fs+      sum_t' = combineTypeShapes sum_t (structTypeFromSV sv)   pure (Constr name es' (Info sum_t') loc, sv)   where     defuncType ::       Monoid als =>       TypeBase Size als ->       TypeBase Size als-    defuncType (Array as u shape t) = Array as u shape (defuncScalar t)+    defuncType (Array u shape t) = Array u shape (defuncScalar t)     defuncType (Scalar t) = Scalar $ defuncScalar t      defuncScalar ::@@ -647,7 +682,7 @@     defuncScalar Arrow {} = Record mempty     defuncScalar (Sum fs) = Sum $ M.map (map defuncType) fs     defuncScalar (Prim t) = Prim t-    defuncScalar (TypeVar as u tn targs) = TypeVar as u tn targs+    defuncScalar (TypeVar u tn targs) = TypeVar u tn targs defuncExp (Constr name _ (Info t) loc) =   error $     "Constructor "@@ -675,11 +710,11 @@  defuncCase :: StaticVal -> Case -> DefM (Maybe (Case, StaticVal)) defuncCase sv (CasePat p e loc) = do-  let p' = updatePat p sv-  case matchPatSV p sv of+  let p' = updatePat (fmap (toParam Observe) p) sv+  case matchPatSV (fmap (toParam Observe) p) sv of     Just env -> do       (e', sv') <- localEnv env $ defuncExp e-      pure $ Just (CasePat p' e' loc, sv')+      pure $ Just (CasePat (fmap toStruct p') e' loc, sv')     Nothing ->       pure Nothing @@ -698,30 +733,30 @@   pure $ Lambda params e0' decl tp loc defuncSoacExp e   | Scalar Arrow {} <- typeOf e = do-      (pats, body, tp) <- etaExpand (RetType [] (typeOf e)) e+      (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique $ typeOf e) e       let env = foldMap envFromPat pats       body' <- localEnv env $ defuncExp' body-      pure $ Lambda pats body' Nothing (Info (mempty, tp)) mempty+      pure $ Lambda pats body' Nothing (Info tp) mempty   | otherwise = defuncExp' e -etaExpand :: PatRetType -> Exp -> DefM ([Pat], Exp, StructRetType)+etaExpand :: ResRetType -> Exp -> DefM ([Pat ParamType], Exp, ResRetType) etaExpand e_t e = do   let (ps, ret) = getType e_t   -- Some careful hackery to avoid duplicate names.-  (_, (pats, vars)) <- second unzip <$> mapAccumLM f [] ps+  (_, (params, vars)) <- second unzip <$> mapAccumLM f [] ps   -- Important that we synthesize new existential names and substitute   -- them into the (body) return type.   ext' <- mapM newName $ retDims ret   let extsubst =         M.fromList . zip (retDims ret) $-          map (SizeSubst . NamedSize . qualName) ext'+          map (ExpSubst . flip sizeFromName mempty . qualName) ext'       ret' = applySubst (`M.lookup` extsubst) ret       e' =         mkApply           e-          (zip3 (map (diet . snd . snd) ps) (repeat Nothing) vars)-          (AppRes (retType ret') ext')-  pure (pats, e', second (const ()) ret)+          (zip3 (map (fst . snd) ps) (repeat Nothing) vars)+          (AppRes (toStruct $ retType ret') ext')+  pure (params, e', ret)   where     getType (RetType _ (Scalar (Arrow _ p d t1 t2))) =       let (ps, r) = getType t2@@ -729,18 +764,14 @@     getType t = ([], t)      f prev (p, (d, t)) = do-      let t' =-            fromStruct t-              `setUniqueness` case d of-                Consume -> Unique-                Observe -> Nonunique+      let t' = second (const d) t       x <- case p of         Named x | x `notElem` prev -> pure x-        _ -> newNameFromString "x"+        _ -> newNameFromString "eta_p"       pure         ( x : prev,           ( Id x (Info t') mempty,-            Var (qualName x) (Info t') mempty+            Var (qualName x) (Info $ toStruct t') mempty           )         ) @@ -756,70 +787,76 @@ -- that have order 0 types (i.e., non-functional). defuncLet ::   [VName] ->-  [Pat] ->+  [Pat ParamType] ->   Exp ->-  StructRetType ->-  DefM ([VName], [Pat], Exp, StaticVal)+  ResRetType ->+  DefM ([VName], [Pat ParamType], Exp, StaticVal, ResType) defuncLet dims ps@(pat : pats) body (RetType ret_dims rettype)   | patternOrderZero pat = do-      let bound_by_pat = (`S.member` freeInPat pat)+      let bound_by_pat = (`S.member` fvVars (freeInPat 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) <-+      (rest_dims', pats', body', sv, sv_t) <-         localEnv env $ defuncLet rest_dims pats body $ RetType ret_dims rettype       closure <- defuncFun dims ps body (RetType ret_dims rettype) mempty       pure         ( pat_dims ++ rest_dims',           pat : pats',           body',-          DynamicFun closure sv+          DynamicFun closure sv,+          sv_t         )   | otherwise = do       (e, sv) <- defuncFun dims ps body (RetType ret_dims rettype) mempty-      pure ([], [], e, sv)+      pure ([], [], e, sv, resTypeFromSV sv) defuncLet _ [] body (RetType _ rettype) = do   (body', sv) <- defuncExp body-  pure ([], [], body', imposeType sv rettype)+  pure+    ( [],+      [],+      body',+      imposeType sv $ resToParam rettype,+      resTypeFromSV sv+    )   where     imposeType Dynamic {} t =-      Dynamic $ fromStruct t+      Dynamic t     imposeType (RecordSV fs1) (Scalar (Record fs2)) =       RecordSV $ M.toList $ M.intersectionWith imposeType (M.fromList fs1) fs2     imposeType sv _ = sv -sizesForAll :: MonadFreshNames m => S.Set VName -> [Pat] -> m ([VName], [Pat])-sizesForAll bound_sizes params = do-  (params', sizes) <- runStateT (mapM (astMap tv) params) mempty-  pure (S.toList sizes, params')+instAnySizes :: MonadFreshNames m => [Pat ParamType] -> m [Pat ParamType]+instAnySizes = traverse $ traverse $ bitraverse onDim pure   where-    bound = bound_sizes <> foldMap patNames params-    tv = identityMapper {mapOnPatType = bitraverse onDim pure}-    onDim (AnySize (Just v)) = do-      modify $ S.insert v-      pure $ NamedSize $ qualName v-    onDim (AnySize Nothing) = do-      v <- lift $ newVName "size"-      modify $ S.insert v-      pure $ NamedSize $ qualName v-    onDim (NamedSize d) = do-      unless (qualLeaf d `S.member` bound) $-        modify $-          S.insert $-            qualLeaf d-      pure $ NamedSize d+    onDim d+      | d == anySize = do+          v <- newVName "size"+          pure $ sizeFromName (qualName v) mempty     onDim d = pure d -unRetType :: StructRetType -> StructType-unRetType (RetType [] t) = t-unRetType (RetType ext t) = first onDim t+unboundSizes :: S.Set VName -> [Pat ParamType] -> [VName]+unboundSizes bound_sizes params = nubOrd $ execState (f params) []   where-    onDim (NamedSize d) | qualLeaf d `elem` ext = AnySize Nothing-    onDim d = d+    f = traverse $ traverse $ bitraverse onDim pure+    bound = bound_sizes <> S.fromList (foldMap patNames params)+    onDim (Var d typ loc) = do+      unless (qualLeaf d `S.member` bound) $ modify (qualLeaf d :)+      pure $ Var d typ loc+    onDim d = pure d +unRetType :: ResRetType -> DefM AppRes+unRetType (RetType [] t) = pure $ AppRes (toStruct t) []+unRetType (RetType ext t) = do+  ext' <- mapM newName ext+  let extsubst =+        M.fromList . zip ext $+          map (ExpSubst . flip sizeFromName mempty . qualName) ext'+  pure $ AppRes (applySubst (`M.lookup` extsubst) $ toStruct t) ext'+ defuncApplyFunction :: Exp -> Int -> DefM (Exp, StaticVal) defuncApplyFunction e@(Var qn (Info t) loc) num_args = do-  let (argtypes, _) = unfoldFunType t+  let (argtypes, rettype) = unfoldFunType t   sv <- lookupVar (toStruct t) (qualLeaf qn)    case sv of@@ -827,12 +864,16 @@       | fullyApplied sv num_args -> do           -- We still need to update the types in case the dynamic           -- function returns a higher-order term.-          let (argtypes', rettype) = dynamicFunType sv argtypes-          pure (Var qn (Info (foldFunType argtypes' $ RetType [] rettype)) loc, sv)+          let (argtypes', rettype') = dynamicFunType sv argtypes+          pure (Var qn (Info (foldFunType argtypes' $ RetType [] rettype')) loc, sv)+      | all orderZero argtypes,+        orderZero rettype -> do+          (params, body, ret) <- etaExpand (RetType [] $ toRes Nonunique t) e+          defuncFun [] params body ret mempty       | otherwise -> do           fname <- newVName $ "dyn_" <> baseString (qualLeaf qn)           let (pats, e0, sv') = liftDynFun (prettyString qn) sv num_args-              (argtypes', rettype) = dynamicFunType sv' argtypes+              (argtypes', rettype') = dynamicFunType sv' argtypes               dims' = mempty            -- Ensure that no parameter sizes are AnySize.  The internaliser@@ -840,18 +881,18 @@           -- first-order.           globals <- asks fst           let bound_sizes = S.fromList dims' <> globals-          (missing_dims, pats') <- sizesForAll bound_sizes pats+          pats' <- instAnySizes pats -          liftValDec fname (RetType [] $ toStruct rettype) (dims' ++ missing_dims) pats' e0+          liftValDec fname (RetType [] rettype') (dims' ++ unboundSizes bound_sizes pats') pats' e0           pure             ( Var                 (qualName fname)-                (Info (foldFunType argtypes' $ RetType [] $ fromStruct rettype))+                (Info (foldFunType argtypes' $ RetType [] rettype'))                 loc,               sv'             )     IntrinsicSV -> pure (e, IntrinsicSV)-    _ -> pure (Var qn (Info (typeFromSV sv)) loc, sv)+    _ -> pure (Var qn (Info (structTypeFromSV sv)) loc, sv) defuncApplyFunction e _ = defuncExp e  -- Embed some information about the original function@@ -867,9 +908,9 @@ defuncApplyArg ::   String ->   (Exp, StaticVal) ->-  (((Diet, Maybe VName), Exp), [(Diet, StructType)]) ->+  (((Diet, Maybe VName), Exp), [ParamType]) ->   DefM (Exp, StaticVal)-defuncApplyArg fname_s (f', f_sv@(LambdaSV pat lam_e_t lam_e closure_env)) (((d, argext), arg), _) = do+defuncApplyArg fname_s (f', LambdaSV pat lam_e_t lam_e closure_env) (((d, argext), arg), _) = do   (arg', arg_sv) <- defuncExp arg   let env' = alwaysMatchPatSV pat arg_sv       dims = mempty@@ -887,15 +928,12 @@   -- of the lifted function, but this is ultimately all a sham   -- and a hack.  There is some piece we're missing.   let params = [closure_pat, pat']-      params_for_rettype = params ++ svParams f_sv ++ svParams arg_sv-      svParams (LambdaSV sv_pat _ _ _) = [sv_pat]-      svParams _ = []-      lifted_rettype = buildRetType closure_env params_for_rettype (unRetType lam_e_t) $ typeOf lam_e'+      lifted_rettype =+        RetType (retDims lam_e_t) $+          combineTypeShapes (retType lam_e_t) (resTypeFromSV sv)        already_bound =-        globals-          <> S.fromList dims-          <> S.map identName (foldMap patIdents params)+        globals <> S.fromList (dims <> foldMap patNames params)        more_dims =         S.toList $@@ -906,22 +944,21 @@   -- expects this.  This is easy, because they are all   -- first-order.   let bound_sizes = S.fromList (dims <> more_dims) <> globals-  (missing_dims, params') <- sizesForAll bound_sizes params+  params' <- instAnySizes params    fname <- newNameFromString fname_s   liftValDec     fname-    (RetType [] $ toStruct lifted_rettype)-    (dims ++ more_dims ++ missing_dims)+    lifted_rettype+    (dims ++ more_dims ++ unboundSizes bound_sizes params')     params'     lam_e'    let f_t = toStruct $ typeOf f'       arg_t = toStruct $ typeOf arg'-      d1 = Observe-      fname_t = foldFunType [(d1, f_t), (d, arg_t)] $ RetType [] lifted_rettype+      fname_t = foldFunType [toParam Observe f_t, toParam d arg_t] lifted_rettype       fname' = Var (qualName fname) (Info fname_t) (srclocOf arg)-      callret = AppRes lifted_rettype []+  callret <- unRetType lifted_rettype    pure     ( mkApply fname' [(Observe, Nothing, f'), (Observe, argext, arg')] callret,@@ -977,10 +1014,10 @@       -- immediately any time we encounter a non-fully-applied       -- intrinsic?       if null $ fst $ unfoldFunType $ appResType appres-        then pure (e', Dynamic $ appResType appres)+        then pure (e', Dynamic $ toParam Observe $ appResType appres)         else do-          (pats, body, tp) <- etaExpand (RetType [] (typeOf e')) e'-          defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) mempty+          (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique $ typeOf e') e'+          defuncExp $ Lambda pats body Nothing (Info tp) mempty  -- | Check if a 'StaticVal' and a given application depth corresponds -- to a fully applied dynamic function.@@ -994,7 +1031,7 @@ -- dimensions, a list of parameters, a function body, and the -- appropriate static value for applying the function at the given -- depth of partial application.-liftDynFun :: String -> StaticVal -> Int -> ([Pat], Exp, StaticVal)+liftDynFun :: String -> StaticVal -> Int -> ([Pat ParamType], Exp, StaticVal) liftDynFun _ (DynamicFun (e, sv) _) 0 = ([], e, sv) liftDynFun s (DynamicFun clsr@(_, LambdaSV pat _ _ _) sv) d   | d > 0 =@@ -1010,7 +1047,7 @@  -- | Converts a pattern to an environment that binds the individual names of the -- pattern to their corresponding types wrapped in a 'Dynamic' static value.-envFromPat :: Pat -> Env+envFromPat :: Pat ParamType -> Env envFromPat pat = case pat of   TuplePat ps _ -> foldMap envFromPat ps   RecordPat fs _ -> foldMap (envFromPat . snd) fs@@ -1027,84 +1064,22 @@   where     d = Binding Nothing $ Dynamic $ Scalar $ Prim $ Signed Int64 --- | Create a new top-level value declaration with the given function name,--- return type, list of parameters, and body expression.-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-    -- forget those return sizes that we forgot to propagate along-    -- the way.  Hopefully the internaliser is conservative and-    -- will insert reshapes...-    bound_here = S.fromList dims <> S.map identName (foldMap patIdents pats)-    mkExt v-      | not $ v `S.member` bound_here = Just v-    mkExt _ = Nothing-    rettype_st = RetType (mapMaybe mkExt (S.toList (freeInType ret)) ++ ret_dims) ret--    dec =-      ValBind-        { valBindEntryPoint = Nothing,-          valBindName = fname,-          valBindRetDecl = Nothing,-          valBindRetType = Info rettype_st,-          valBindTypeParams = dims',-          valBindParams = pats,-          valBindBody = body,-          valBindDoc = Nothing,-          valBindAttrs = mempty,-          valBindLocation = mempty-        }- -- | Given a closure environment, construct a record pattern that -- binds the closed over variables.  Insert wildcard for any patterns -- that would otherwise clash with size parameters.-buildEnvPat :: [VName] -> Env -> Pat+buildEnvPat :: [VName] -> Env -> Pat ParamType buildEnvPat sizes env = RecordPat (map buildField $ M.toList env) mempty   where     buildField (vn, Binding _ sv) =       ( nameFromString (prettyString vn),         if vn `elem` sizes-          then Wildcard (Info $ typeFromSV sv) mempty-          else Id vn (Info $ typeFromSV sv) mempty+          then Wildcard (Info $ paramTypeFromSV sv) mempty+          else Id vn (Info $ paramTypeFromSV sv) mempty       ) --- | Given a closure environment pattern and the type of a term,--- construct the type of that term, where uniqueness is set to--- `Nonunique` for those arrays that are bound in the environment or--- pattern (except if they are unique there).  This ensures that a--- lifted function can create unique arrays as long as they do not--- alias any of its parameters.  XXX: it is not clear that this is a--- sufficient property, unfortunately.-buildRetType :: Env -> [Pat] -> StructType -> PatType -> PatType-buildRetType env pats = comb-  where-    bound =-      S.fromList (M.keys env) <> S.map identName (foldMap patIdents pats)-    boundAsUnique v =-      maybe False (unique . unInfo . identType) $-        find ((== v) . identName) $-          S.toList $-            foldMap patIdents pats-    problematic v = (v `S.member` bound) && not (boundAsUnique v)-    comb (Scalar (Record fs_annot)) (Scalar (Record fs_got)) =-      Scalar $ Record $ M.intersectionWith comb fs_annot fs_got-    comb (Scalar (Sum cs_annot)) (Scalar (Sum cs_got)) =-      Scalar $ Sum $ M.intersectionWith (zipWith comb) cs_annot cs_got-    comb (Scalar Arrow {}) t =-      descend t-    comb got et =-      descend $ fromStruct got `setAliases` aliases et--    descend t@Array {}-      | any (problematic . aliasVar) (aliases t) = t `setUniqueness` Nonunique-    descend (Scalar (Record t)) = Scalar $ Record $ fmap descend t-    descend t = t- -- | Compute the corresponding type for the *representation* of a -- given static value (not the original possibly higher-order value).-typeFromSV :: StaticVal -> PatType+typeFromSV :: StaticVal -> ParamType typeFromSV (Dynamic tp) =   tp typeFromSV (LambdaSV _ _ _ env) =@@ -1120,24 +1095,33 @@   let svs' = map typeFromSV svs    in Scalar $ Sum $ M.insert name svs' $ M.fromList fields typeFromSV (HoleSV t _) =-  t+  toParam Observe t typeFromSV IntrinsicSV =   error "Tried to get the type from the static value of an intrinsic." +resTypeFromSV :: StaticVal -> ResType+resTypeFromSV = paramToRes . typeFromSV++structTypeFromSV :: StaticVal -> StructType+structTypeFromSV = toStruct . typeFromSV++paramTypeFromSV :: StaticVal -> ParamType+paramTypeFromSV = typeFromSV+ -- | Construct the type for a fully-applied dynamic function from its -- static value and the original types of its arguments.-dynamicFunType :: StaticVal -> [(Diet, StructType)] -> ([(Diet, PatType)], PatType)+dynamicFunType :: StaticVal -> [ParamType] -> ([ParamType], ResType) dynamicFunType (DynamicFun _ sv) (p : ps) =   let (ps', ret) = dynamicFunType sv ps-   in (second fromStruct p : ps', ret)-dynamicFunType sv _ = ([], typeFromSV sv)+   in (p : ps', ret)+dynamicFunType sv _ = ([], resTypeFromSV sv)  -- | Match a pattern with its static value. Returns an environment -- with the identifier components of the pattern mapped to the -- corresponding subcomponents of the static value.  If this function -- returns 'Nothing', then it corresponds to an unmatchable case. -- These should only occur for 'Match' expressions.-matchPatSV :: Pat -> StaticVal -> Maybe Env+matchPatSV :: Pat ParamType -> StaticVal -> Maybe Env matchPatSV (TuplePat ps _) (RecordSV ls) =   mconcat <$> zipWithM (\p (_, sv) -> matchPatSV p sv) ps ls matchPatSV (RecordPat ps _) (RecordSV ls)@@ -1157,7 +1141,7 @@       else dim_env <> M.singleton vn (Binding Nothing sv)   where     dim_env =-      M.fromList $ map (,i64) $ S.toList $ freeInType t+      M.fromList $ map (,i64) $ S.toList $ fvVars $ freeInType t     i64 = Binding Nothing $ Dynamic $ Scalar $ Prim $ Signed Int64 matchPatSV (Wildcard _ _) _ = pure mempty matchPatSV (PatAscription pat _ _) sv = matchPatSV pat sv@@ -1178,7 +1162,7 @@   | otherwise =       error $ "matchPatSV: missing constructor in type: " ++ prettyString c1 matchPatSV pat (Dynamic t) = matchPatSV pat $ svFromType t-matchPatSV pat (HoleSV t _) = matchPatSV pat $ svFromType t+matchPatSV pat (HoleSV t _) = matchPatSV pat $ svFromType $ toParam Observe t matchPatSV pat sv =   error $     "Tried to match pattern\n"@@ -1186,14 +1170,14 @@       ++ "\n with static value\n"       ++ show sv -alwaysMatchPatSV :: Pat -> StaticVal -> Env+alwaysMatchPatSV :: Pat ParamType -> StaticVal -> Env alwaysMatchPatSV pat sv = fromMaybe bad $ matchPatSV pat sv   where     bad = error $ unlines [prettyString pat, "cannot match StaticVal", show sv]  -- | Given a pattern and the static value for the defunctionalized argument, -- update the pattern to reflect the changes in the types.-updatePat :: Pat -> StaticVal -> Pat+updatePat :: Pat ParamType -> StaticVal -> Pat ParamType updatePat (TuplePat ps loc) (RecordSV svs) =   TuplePat (zipWith updatePat ps $ map snd svs) loc updatePat (RecordPat ps loc) (RecordSV svs)@@ -1207,7 +1191,7 @@ 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+  Id vn (Info $ comb tp $ paramTypeFromSV sv) loc   where     -- Preserve any original zeroth-order types.     comb (Scalar Arrow {}) t2 = t2@@ -1218,20 +1202,20 @@     comb t1 _ = t1 -- t1 must be array or prim. updatePat pat@(Wildcard (Info tp) loc) sv   | orderZero tp = pat-  | otherwise = Wildcard (Info $ typeFromSV sv) loc+  | otherwise = Wildcard (Info $ paramTypeFromSV sv) loc updatePat (PatAscription pat _ _) sv =   updatePat pat sv updatePat p@PatLit {} _ = p updatePat pat@(PatConstr c1 (Info t) ps loc) sv@(SumSV _ svs _)   | orderZero t = pat-  | otherwise = PatConstr c1 (Info t') ps' loc+  | otherwise = PatConstr c1 (Info $ toParam Observe t') ps' loc   where-    t' = typeFromSV sv `setUniqueness` Nonunique+    t' = resTypeFromSV sv     ps' = zipWith updatePat ps svs updatePat (PatConstr c1 _ ps loc) (Dynamic t) =-  PatConstr c1 (Info t) ps loc+  PatConstr c1 (Info $ toParam Observe t) ps loc updatePat pat (Dynamic t) = updatePat pat (svFromType t)-updatePat pat (HoleSV t _) = updatePat pat (svFromType t)+updatePat pat (HoleSV t _) = updatePat pat (svFromType $ toParam Observe t) updatePat pat sv =   error $     "Tried to update pattern\n"@@ -1242,7 +1226,7 @@ -- | Convert a record (or tuple) type to a record static value. This -- is used for "unwrapping" tuples and records that are nested in -- 'Dynamic' static values.-svFromType :: PatType -> StaticVal+svFromType :: ParamType -> StaticVal svFromType (Scalar (Record fs)) = RecordSV . M.toList $ M.map svFromType fs svFromType t = Dynamic t @@ -1273,18 +1257,14 @@       show name         ++ " has type parameters, "         ++ "but the defunctionaliser expects a monomorphic input program."-  (tparams', params', body', sv) <-+  (tparams', params', body', sv, sv_t) <-     defuncLet (map typeParamName tparams) params body $ RetType ret_dims rettype   globals <- asks fst-  let bound_sizes = foldMap patNames params' <> S.fromList tparams' <> globals-      rettype' =-        -- FIXME: dubious that we cannot assume that all sizes in the-        -- body are in scope.  This is because when we insert-        -- applications of lifted functions, we don't properly update-        -- the types in the return type annotation.-        combineTypeShapes rettype $ first (anyDimIfNotBound bound_sizes) $ toStruct $ typeOf body'-      ret_dims' = filter (`S.member` freeInType rettype') ret_dims-  (missing_dims, params'') <- sizesForAll bound_sizes params'+  let bound_sizes = S.fromList (foldMap patNames params') <> S.fromList tparams' <> globals+  params'' <- instAnySizes params'+  let rettype' = combineTypeShapes rettype sv_t+      tparams'' = tparams' ++ unboundSizes bound_sizes params''+      ret_dims' = filter (`notElem` bound_sizes) $ S.toList $ fvVars $ freeInType rettype'    pure     ( valbind@@ -1294,8 +1274,7 @@               if null params'                 then RetType ret_dims' $ rettype' `setUniqueness` Nonunique                 else RetType ret_dims' rettype',-          valBindTypeParams =-            map (`TypeParamDim` mempty) $ tparams' ++ missing_dims,+          valBindTypeParams = map (`TypeParamDim` mempty) tparams'',           valBindParams = params'',           valBindBody = body'         },@@ -1304,10 +1283,6 @@           (Just (first (map typeParamName) (valBindTypeScheme valbind)))           sv     )-  where-    anyDimIfNotBound bound_sizes (NamedSize v)-      | qualLeaf v `S.notMember` bound_sizes = AnySize $ Just $ qualLeaf v-    anyDimIfNotBound _ d = d  -- | Defunctionalize a list of top-level declarations. defuncVals :: [ValBind] -> DefM ()

@@ -250,9 +250,8 @@           mapOnName = \v ->             pure $ qualLeaf $ fst $ lookupSubstInScope (qualName v) scope,           mapOnStructType = astMap (substituter scope),-          mapOnPatType = astMap (substituter scope),-          mapOnStructRetType = astMap (substituter scope),-          mapOnPatRetType = astMap (substituter scope)+          mapOnParamType = astMap (substituter scope),+          mapOnResRetType = astMap (substituter scope)         }     onExp scope e =       -- One expression is tricky, because it interacts with scoping rules.@@ -270,6 +269,9 @@ transformStructType :: StructType -> TransformM StructType transformStructType = transformNames +transformResType :: ResType -> TransformM ResType+transformResType = transformNames+ transformExp :: Exp -> TransformM Exp transformExp = transformNames @@ -287,7 +289,7 @@   entry' <- traverse (traverse transformEntry) entry   name' <- transformName name   tdecl' <- traverse transformTypeExp tdecl-  t' <- transformStructType t+  t' <- transformResType t   e' <- transformExp e   tparams' <- traverse transformNames tparams   params' <- traverse transformNames params

@@ -65,7 +65,12 @@ runGenOpaque = flip runState mempty  addType :: Name -> I.OpaqueType -> GenOpaque ()-addType s t = modify (<> I.OpaqueTypes [(s, t)])+addType name t = modify $ \(I.OpaqueTypes ts) ->+  case find ((== name) . fst) ts of+    Just (_, t')+      | t /= t' ->+          error $ "Duplicate definition of entry point type " <> E.prettyString name+    _ -> I.OpaqueTypes ts <> I.OpaqueTypes [(name, t)]  isRecord :: VisibleTypes -> E.TypeExp E.Info VName -> Maybe (M.Map Name (E.TypeExp E.Info VName)) isRecord _ (E.TERecord fs _) = Just $ M.fromList fs@@ -109,13 +114,13 @@   | E.Scalar (E.Prim E.Unsigned {}) <- E.entryType t,     [I.Prim ts0] <- ts =       pure (u, I.TypeTransparent $ I.ValueType I.Unsigned (I.Rank 0) ts0)-  | E.Array _ _ _ (E.Prim E.Unsigned {}) <- E.entryType t,+  | E.Array _ _ (E.Prim E.Unsigned {}) <- E.entryType t,     [I.Array ts0 r _] <- ts =       pure (u, I.TypeTransparent $ I.ValueType I.Unsigned r ts0)   | E.Scalar E.Prim {} <- E.entryType t,     [I.Prim ts0] <- ts =       pure (u, I.TypeTransparent $ I.ValueType I.Signed (I.Rank 0) ts0)-  | E.Array _ _ _ E.Prim {} <- E.entryType t,+  | E.Array _ _ E.Prim {} <- E.entryType t,     [I.Array ts0 r _] <- ts =       pure (u, I.TypeTransparent $ I.ValueType I.Signed r ts0)   | otherwise = do

@@ -7,6 +7,8 @@  import Control.Monad import Control.Monad.Reader+import Data.Bifunctor+import Data.Foldable (toList) import Data.List (elemIndex, find, intercalate, intersperse, transpose) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE@@ -40,31 +42,31 @@ internaliseFunName :: VName -> Name internaliseFunName = nameFromString . prettyString +shiftRetAls :: Int -> RetAls -> RetAls+shiftRetAls d (RetAls pals rals) = RetAls pals $ map (+ d) rals+ internaliseValBind :: VisibleTypes -> E.ValBind -> InternaliseM ()-internaliseValBind types fb@(E.ValBind entry fname retdecl (Info rettype) tparams params body _ attrs loc) = do+internaliseValBind types fb@(E.ValBind entry fname _ (Info rettype) tparams params body _ attrs loc) = do   bindingFParams tparams params $ \shapeparams params' -> do     let shapenames = map I.paramName shapeparams--    msg <- case retdecl of-      Just dt ->-        errorMsg-          . ("Function return value does not match shape of type " :)-          <$> typeExpForError dt-      Nothing -> pure $ errorMsg ["Function return value does not match shape of declared return type."]+        all_params = map pure shapeparams ++ concat params'+        msg = errorMsg ["Function return value does not match shape of declared return type."]      (body', rettype') <- buildBody $ do       body_res <- internaliseExp (baseString fname <> "_res") body-      rettype' <--        zeroExts . internaliseReturnType rettype <$> mapM subExpType body_res+      (rettype', retals) <-+        first zeroExts . unzip . internaliseReturnType (map (fmap paramDeclType) all_params) rettype+          <$> mapM subExpType body_res+       body_res' <-         ensureResultExtShape msg loc (map I.fromDecl rettype') $ subExpsRes body_res+      let num_ctx = length (shapeContext rettype')       pure         ( body_res',-          replicate (length (shapeContext rettype')) (I.Prim int64) ++ rettype'+          replicate num_ctx (I.Prim int64, mempty)+            ++ zip rettype' (map (shiftRetAls num_ctx) retals)         ) -    let all_params = shapeparams ++ concat params'-     attrs' <- internaliseAttrs attrs      let fd =@@ -73,7 +75,7 @@             attrs'             (internaliseFunName fname)             rettype'-            all_params+            (foldMap toList all_params)             body'      if null params'@@ -83,9 +85,10 @@           fname           fd           ( shapenames,-            map declTypeOf $ concat params',-            all_params,-            applyRetType rettype' all_params+            map declTypeOf $ foldMap (foldMap toList) params',+            foldMap toList all_params,+            fmap (`zip` map snd rettype')+              . applyRetType (map fst rettype') (foldMap toList all_params)           )    case entry of@@ -98,14 +101,16 @@ generateEntryPoint types (E.EntryPoint e_params e_rettype) vb = do   let (E.ValBind _ ofname _ (Info rettype) tparams params _ _ attrs loc) = vb   bindingFParams tparams params $ \shapeparams params' -> do-    let entry_rettype = internaliseEntryReturnType rettype+    let all_params = map pure shapeparams ++ concat params'+        (entry_rettype, retals) =+          unzip $ map unzip $ internaliseEntryReturnType (map (fmap paramDeclType) all_params) rettype         (entry', opaques) =           entryPoint             types             (baseName ofname)-            (zip e_params params')+            (zip e_params $ map (foldMap toList) params')             (e_rettype, map (map I.rankShaped) entry_rettype)-        args = map (I.Var . I.paramName) $ concat params'+        args = map (I.Var . I.paramName) $ foldMap (foldMap toList) params'      addOpaques opaques @@ -117,20 +122,25 @@         Just ses ->           pure ses         Nothing ->-          fst <$> funcall "entry_result" (E.qualName ofname) args loc+          funcall "entry_result" (E.qualName ofname) args loc       ctx <-         extractShapeContext (zeroExts $ concat entry_rettype)           <$> mapM (fmap I.arrayDims . subExpType) vals-      pure (subExpsRes $ ctx ++ vals, map (const (I.Prim int64)) ctx)+      pure (subExpsRes $ ctx ++ vals, map (const (I.Prim int64, mempty)) ctx)      attrs' <- internaliseAttrs attrs+    let num_ctx = length ctx_ts     addFunDef $       I.FunDef         (Just entry')         attrs'         ("entry_" <> baseName ofname)-        (ctx_ts ++ zeroExts (concat entry_rettype))-        (shapeparams ++ concat params')+        ( ctx_ts+            ++ zip+              (zeroExts (concat entry_rettype))+              (map (shiftRetAls num_ctx) $ concat retals)+        )+        (shapeparams ++ foldMap (foldMap toList) params')         entry_body   where     zeroExts ts = generaliseExtTypes ts ts@@ -320,19 +330,6 @@    se <- letSubExp desc (I.BasicOp $ I.Iota num_elems start' step it)   pure [se]-internaliseAppExp desc (E.AppRes et ext) (E.Coerce e dt loc) = do-  ses <- internaliseExp desc e-  ts <- internaliseReturnType (E.RetType ext (E.toStruct et)) <$> mapM subExpType ses-  dt' <- typeExpForError dt-  forM (zip ses ts) $ \(e', t') -> do-    dims <- arrayDims <$> subExpType e'-    let parts =-          ["Value of (core language) shape ("]-            ++ intersperse ", " (map (ErrorVal int64) dims)-            ++ [") cannot match shape of type `"]-            ++ dt'-            ++ ["`."]-    ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e' internaliseAppExp desc (E.AppRes et ext) e@E.Apply {} =   case findFuncall e of     (FunctionHole loc, _args) -> do@@ -343,7 +340,7 @@       -- application.  One caveat is that we need to replace any       -- existential sizes, too (with zeroes, because they don't       -- matter).-      let subst = zip ext $ repeat $ E.SizeSubst $ E.ConstSize 0+      let subst = zip ext $ repeat $ E.ExpSubst $ E.sizeFromInteger 0 mempty           et' = E.applySubst (`lookup` subst) et       internaliseExp desc (E.Hole (Info et') loc)     (FunctionName qfname, args) -> do@@ -386,10 +383,10 @@               let tag ses = [(se, I.Observe) | se <- ses]               args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)               let args'' = concatMap tag args'-              letValExp' desc $ I.Apply fname args'' [I.Prim rettype] (Safe, loc, [])+              letValExp' desc $ I.Apply fname args'' [(I.Prim rettype, mempty)] (Safe, loc, [])           | otherwise -> do               args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)-              fst <$> funcall desc qfname args' loc+              funcall desc qfname args' loc internaliseAppExp desc _ (E.LetPat sizes pat e body _) =   internalisePat desc sizes pat e $ internaliseExp desc body internaliseAppExp _ _ (E.LetFun ofname _ _ _) =@@ -468,7 +465,7 @@        ts <- mapM subExpType mergeinit       bindingLoopParams sparams' mergepat ts $ \shapepat mergepat' ->-        bindingLambdaParams [x] (map rowType arr_ts) $ \x_params -> do+        bindingLambdaParams [toParam E.Observe <$> x] (map rowType arr_ts) $ \x_params -> do           let loopvars = zip x_params arr'           forLoop mergepat' shapepat mergeinit $             I.ForLoop i Int64 w loopvars@@ -508,8 +505,15 @@                       | not $ primType $ paramType p ->                           Reshape I.ReshapeCoerce (I.arrayShape $ paramType p) v                     _ -> SubExp se-          internaliseExp1 "loop_cond" cond +          -- As the condition expression is inserted twice, we have to+          -- avoid shadowing (#1935).+          (cond_stms, cond') <-+            uncurry (flip renameStmsWith)+              =<< collectStms (internaliseExp1 "loop_cond" cond)+          addStms cond_stms+          pure cond'+         addStms init_loop_cond_stms          bodyFromStms $ do@@ -547,7 +551,7 @@             ) 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+      src_t = E.identType src       e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc   internaliseExp desc $     E.AppExp@@ -581,7 +585,7 @@   internaliseExp desc e internaliseExp desc (E.Hole (Info t) loc) = do   let msg = docText $ "Reached hole of type: " <> align (pretty t)-      ts = internaliseType (E.toStruct t)+      ts = foldMap toList $ internaliseType (E.toStruct t)   c <- assert "hole_c" (constant False) (errorMsg [ErrorString msg]) loc   case mapM hasStaticShape ts of     Nothing ->@@ -644,7 +648,7 @@         letSubExp desc $ I.BasicOp $ I.Reshape I.ReshapeArbitrary new_shape' flat_arr   | otherwise = do       es' <- mapM (internaliseExp "arr_elem") es-      let arr_t_ext = internaliseType $ E.toStruct arr_t+      let arr_t_ext = foldMap toList $ internaliseType $ E.toStruct arr_t        rowtypes <-         case mapM (fmap rowType . hasStaticShape . I.fromDecl) arr_t_ext of@@ -685,6 +689,19 @@       Just ([], [e]) internaliseExp desc (E.Ascript e _ _) =   internaliseExp desc e+internaliseExp desc (E.Coerce e _ (Info et) loc) = do+  ses <- internaliseExp desc e+  ts <- internaliseCoerceType (E.toStruct et) <$> mapM subExpType ses+  dt' <- typeExpForError $ toStruct et+  forM (zip ses ts) $ \(e', t') -> do+    dims <- arrayDims <$> subExpType e'+    let parts =+          ["Value of (core language) shape ("]+            ++ intersperse ", " (map (ErrorVal int64) dims)+            ++ [") cannot match shape of type `"]+            ++ dt'+            ++ ["`."]+    ensureExtShape (errorMsg parts) loc (I.fromDecl t') desc e' internaliseExp desc (E.Negate e _) = do   e' <- internaliseExp1 "negate_arg" e   et <- subExpType e'@@ -728,7 +745,7 @@ internaliseExp desc (E.RecordUpdate src fields ve _ _) = do   src' <- internaliseExp desc src   ve' <- internaliseExp desc ve-  replace (E.typeOf src `setAliases` ()) fields ve' src'+  replace (E.typeOf src) fields ve' src'   where     replace (E.Scalar (E.Record m)) (f : fs) ve' src'       | Just t <- M.lookup f m = do@@ -817,12 +834,11 @@ -- overloaded. internaliseExp desc (E.Project k e (Info rt) _) = do   let i' = sum . map internalisedTypeSize $-        case E.typeOf e `setAliases` () of+        case E.typeOf e of           E.Scalar (Record fs) ->             map snd $ takeWhile ((/= k) . fst) $ sortFields fs           t -> [t]-  take (internalisedTypeSize $ rt `setAliases` ()) . drop i'-    <$> internaliseExp desc e+  take (internalisedTypeSize rt) . drop i' <$> internaliseExp desc e internaliseExp _ e@E.Lambda {} =   error $ "internaliseExp: Unexpected lambda at " ++ locStr (srclocOf e) internaliseExp _ e@E.OpSection {} =@@ -849,7 +865,7 @@         _ -> pure ()       pure arg' -internalisePatLit :: E.PatLit -> E.PatType -> I.PrimValue+internalisePatLit :: E.PatLit -> E.StructType -> I.PrimValue internalisePatLit (E.PatLitPrim v) _ =   internalisePrimValue v internalisePatLit (E.PatLitInt x) (E.Scalar (E.Prim (E.Signed it))) =@@ -862,7 +878,7 @@   error $ "Nonsensical pattern and type: " ++ show (l, t)  generateCond ::-  E.Pat ->+  E.Pat StructType ->   [I.SubExp] ->   InternaliseM ([Maybe I.PrimValue], [I.SubExp]) generateCond orig_p orig_ses = do@@ -927,7 +943,7 @@ internalisePat ::   String ->   [E.SizeBinder VName] ->-  E.Pat ->+  E.Pat StructType ->   E.Exp ->   InternaliseM a ->   InternaliseM a@@ -935,19 +951,19 @@   ses <- internaliseExp desc' e   internalisePat' sizes p ses m   where-    desc' = case S.toList $ E.patIdents p of+    desc' = case E.patIdents p of       [v] -> baseString $ E.identName v       _ -> desc  internalisePat' ::   [E.SizeBinder VName] ->-  E.Pat ->+  E.Pat StructType ->   [I.SubExp] ->   InternaliseM a ->   InternaliseM a internalisePat' sizes p ses m = do   ses_ts <- mapM subExpType ses-  stmPat p ses_ts $ \pat_names -> do+  stmPat (toParam E.Observe <$> p) ses_ts $ \pat_names -> do     bindExtSizes (AppRes (E.patternType p) (map E.sizeName sizes)) ses     forM_ (zip pat_names ses) $ \(v, se) ->       letBindNames [v] $ I.BasicOp $ I.SubExp se@@ -1031,7 +1047,7 @@           ( eBinOp               (Add Int64 I.OverflowWrap)               x-              (eBinOp (Sub Int64 I.OverflowWrap) y (eSignum $ toExp s'))+              (eBinOp (Sub Int64 I.OverflowWrap) y (eSignum y))           )           y   n <- letSubExp "n" =<< divRounding (toExp j_m_i) (toExp s')@@ -1065,14 +1081,14 @@   i_lte_j <- letSubExp "i_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) i' j'   forwards_ok <-     letSubExp "forwards_ok"-      =<< eAll [zero_lte_i, zero_lte_i, i_lte_j, zero_leq_i_p_m_t_s, i_p_m_t_s_lth_w]+      =<< eAll [zero_lte_i, i_lte_j, zero_leq_i_p_m_t_s, i_p_m_t_s_lth_w]    negone_lte_j <- letSubExp "negone_lte_j" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) negone j'   j_lte_i <- letSubExp "j_lte_i" $ I.BasicOp $ I.CmpOp (I.CmpSle Int64) j' i'   backwards_ok <-     letSubExp "backwards_ok"       =<< eAll-        [negone_lte_j, negone_lte_j, j_lte_i, zero_leq_i_p_m_t_s, i_p_m_t_s_leq_w]+        [negone_lte_j, j_lte_i, zero_leq_i_p_m_t_s, i_p_m_t_s_leq_w]    slice_ok <-     letSubExp "slice_ok"@@ -1471,7 +1487,7 @@ internaliseLambda :: InternaliseLambda internaliseLambda (E.Parens e _) rowtypes =   internaliseLambda e rowtypes-internaliseLambda (E.Lambda params body _ (Info (_, RetType _ 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'@@ -1677,15 +1693,15 @@       arrs <- internaliseExpToVars "unflatten_arr" arr       n' <- internaliseExp1 "n" n       m' <- internaliseExp1 "m" m-      -- The unflattened dimension needs to have the same number of elements-      -- as the original dimension.+      -- Each dimension must be nonnegative, and the unflattened+      -- dimension needs to have the same number of elements as the+      -- original dimension.       old_dim <- I.arraysSize 0 <$> mapM lookupType arrs       dim_ok <--        letSubExp "dim_ok"-          =<< eCmpOp-            (I.CmpEq I.int64)-            (eBinOp (I.Mul Int64 I.OverflowUndef) (eSubExp n') (eSubExp m'))-            (eSubExp old_dim)+        letSubExp "dim_ok" <=< toExp $+          pe64 old_dim .==. pe64 n' * pe64 m'+            .&&. pe64 n' .>=. 0+            .&&. pe64 m' .>=. 0       dim_ok_cert <-         assert           "dim_ok_cert"@@ -1736,24 +1752,19 @@       let conc xarr yarr =             I.BasicOp $ I.Concat 0 (xarr :| [yarr]) ressize       mapM (letSubExp desc) $ zipWith conc xs ys-    handleRest [offset, e] "rotate" = Just $ \desc -> do-      offset' <- internaliseExp1 "rotation_offset" offset-      internaliseOperation desc e $ \v -> do-        r <- I.arrayRank <$> lookupType v-        let zero = intConst Int64 0-            offsets = offset' : replicate (r - 1) zero-        pure $ I.Rotate offsets v     handleRest [e] "transpose" = Just $ \desc ->       internaliseOperation desc e $ \v -> do         r <- I.arrayRank <$> lookupType v         pure $ I.Rearrange ([1, 0] ++ [2 .. r - 1]) v     handleRest [x, y] "zip" = Just $ \desc ->-      mapM (letSubExp "zip_copy" . BasicOp . Copy)+      mapM (letSubExp "zip_copy" . BasicOp . Replicate mempty . I.Var)         =<< ( (++)                 <$> internaliseExpToVars (desc ++ "_zip_x") x                 <*> internaliseExpToVars (desc ++ "_zip_y") y             )-    handleRest [x] "unzip" = Just $ flip internaliseExp x+    handleRest [x] "unzip" = Just $ \desc ->+      mapM (letSubExp desc . BasicOp . Replicate mempty . I.Var)+        =<< internaliseExpToVars desc x     handleRest [arr, offset, n1, s1, n2, s2] "flat_index_2d" = Just $ \desc -> do       flatIndexHelper desc loc arr offset [(n1, s1), (n2, s2)]     handleRest [arr1, offset, s1, s2, arr2] "flat_update_2d" = Just $ \desc -> do@@ -1840,7 +1851,7 @@           bodyNames = indexName <> valueNames           bodyParams = zipWith (I.Param mempty) bodyNames paramTypes -      -- This body is prettyString boring right now, as every input is exactly the output.+      -- This body is boring right now, as every input is exactly the output.       -- But it can get funky later on if fused with something else.       body <- localScope (scopeOfLParams bodyParams) . buildBody_ $ do         let outs = concat (replicate (length valueNames) indexName) ++ valueNames@@ -1962,10 +1973,9 @@   QualName VName ->   [SubExp] ->   SrcLoc ->-  InternaliseM ([SubExp], [I.ExtType])+  InternaliseM [SubExp] funcall desc (QualName _ fname) args loc = do-  (shapes, value_paramts, fun_params, rettype_fun) <--    lookupFunction fname+  (shapes, value_paramts, fun_params, rettype_fun) <- lookupFunction fname   argts <- mapM subExpType args    shapeargs <- argShapes shapes fun_params argts@@ -2000,10 +2010,8 @@     Just ts -> do       safety <- askSafety       attrs <- asks envAttrs-      ses <--        attributing attrs . letValExp' desc $-          I.Apply (internaliseFunName fname) (zip args' diets) ts (safety, loc, mempty)-      pure (ses, map I.fromDecl ts)+      attributing attrs . letValExp' desc $+        I.Apply (internaliseFunName fname) (zip args' diets) ts (safety, loc, mempty)  -- Bind existential names defined by an expression, based on the -- concrete values that expression evaluated to.  This most@@ -2012,7 +2020,7 @@ -- language. bindExtSizes :: AppRes -> [SubExp] -> InternaliseM () bindExtSizes (AppRes ret retext) ses = do-  let ts = internaliseType $ E.toStruct ret+  let ts = foldMap toList $ internaliseType $ E.toStruct ret   ses_ts <- mapM subExpType ses    let combine t1 t2 =@@ -2148,53 +2156,41 @@           (resultBodyM [this_one])           (resultBodyM [next_one]) -typeExpForError :: E.TypeExp Info VName -> InternaliseM [ErrorMsgPart SubExp]-typeExpForError (E.TEVar qn _) =-  pure [ErrorString $ prettyText qn]-typeExpForError (E.TEParens te _) = do-  msg <- typeExpForError te-  pure $ ["("] <> msg <> [")"]-typeExpForError (E.TEUnique te _) =-  ("*" :) <$> typeExpForError te-typeExpForError (E.TEDim dims te _) =-  (ErrorString ("?" <> dims' <> ".") :) <$> typeExpForError te+sizeExpForError :: E.Size -> InternaliseM [ErrorMsgPart SubExp]+sizeExpForError e = do+  e' <- internaliseExp1 "size" e+  pure ["[", ErrorVal int64 e', "]"]++typeExpForError :: E.TypeBase Size u -> InternaliseM [ErrorMsgPart SubExp]+typeExpForError (E.Scalar (E.Prim t)) = pure [ErrorString $ prettyText t]+typeExpForError (E.Scalar (E.TypeVar _ v args)) = do+  args' <- concat <$> mapM onArg args+  pure $ intersperse " " $ ErrorString (prettyText v) : args'   where-    dims' = mconcat (map onDim dims)-    onDim d = "[" <> prettyText d <> "]"-typeExpForError (E.TEArray d te _) =-  (<>) <$> sizeExpForError d <*> typeExpForError te-typeExpForError (E.TETuple tes _) = do-  tes' <- mapM typeExpForError tes-  pure $ ["("] ++ intercalate [", "] tes' ++ [")"]-typeExpForError (E.TERecord fields _) = do-  fields' <- mapM onField fields-  pure $ ["{"] ++ intercalate [", "] fields' ++ ["}"]+    onArg (TypeArgDim d) = sizeExpForError d+    onArg (TypeArgType t) = typeExpForError t+typeExpForError (E.Scalar (E.Record fs))+  | Just ts <- E.areTupleFields fs = do+      ts' <- mapM typeExpForError ts+      pure $ ["("] ++ intercalate [", "] ts' ++ [")"]+  | otherwise = do+      fs' <- mapM onField $ M.toList fs+      pure $ ["{"] ++ intercalate [", "] fs' ++ ["}"]   where     onField (k, te) =       (ErrorString (prettyText k <> ": ") :) <$> typeExpForError te-typeExpForError (E.TEArrow _ t1 t2 _) = do-  t1' <- typeExpForError t1-  t2' <- typeExpForError t2-  pure $ t1' ++ [" -> "] ++ t2'-typeExpForError (E.TEApply t arg _) = do-  t' <- typeExpForError t-  arg' <- case arg of-    TypeArgExpType argt -> typeExpForError argt-    TypeArgExpSize d -> sizeExpForError d-  pure $ t' ++ [" "] ++ arg'-typeExpForError (E.TESum cs _) = do-  cs' <- mapM (onClause . snd) cs+typeExpForError (E.Array _ shape et) = do+  shape' <- mconcat <$> mapM sizeExpForError (E.shapeDims shape)+  et' <- typeExpForError $ Scalar et+  pure $ shape' ++ et'+typeExpForError (E.Scalar (E.Sum cs)) = do+  cs' <- mapM onConstructor $ M.toList cs   pure $ intercalate [" | "] cs'   where-    onClause c = do-      c' <- mapM typeExpForError c-      pure $ intercalate [" "] c'--sizeExpForError :: E.SizeExp Info VName -> InternaliseM [ErrorMsgPart SubExp]-sizeExpForError (SizeExp e _) = do-  e' <- internaliseExp1 "size" e-  pure ["[", ErrorVal int64 e', "]"]-sizeExpForError SizeExpAny {} = pure ["[]"]+    onConstructor (c, ts) = do+      ts' <- mapM typeExpForError ts+      pure $ ErrorString ("#" <> prettyText c <> " ") : intercalate [" "] ts'+typeExpForError (E.Scalar Arrow {}) = pure ["#<fun>"]  -- A smart constructor that compacts neighbouring literals for easier -- reading in the IR.

@@ -0,0 +1,367 @@+-- | This full normalisation module converts a well-typed, polymorphic,+-- module-free Futhark program into an equivalent with only simple expresssions.+-- Notably, all non-trivial expression are converted into a list of+-- let-bindings to make them simpler, with no nested apply, nested lets...+-- This module only performs synthatic operations.+--+-- Also, it performs desugaring that is:+-- * Turn operator section into lambda+-- * turn BinOp into application (&& and || are converted to if structure)+-- * turn `let x [i] = e1` into `let x = x with [i] = e1`+-- * binds all implicit sizes+--+-- This is currently not done for expressions inside sizes, this processing+-- still needed in monomorphisation for now.+module Futhark.Internalise.FullNormalise (transformProg) where++import Control.Monad.Reader+import Control.Monad.State+import Data.Bifunctor+import Data.List.NonEmpty qualified as NE+import Data.Map qualified as M+import Data.Text qualified as T+import Futhark.MonadFreshNames+import Language.Futhark+import Language.Futhark.Traversals+import Language.Futhark.TypeChecker.Types++-- Modifier to apply on binding, this is used to propagate attributes and move assertions+data BindModifier+  = Ass Exp (Info T.Text) SrcLoc+  | Att (AttrInfo VName)++-- Apply a list of modifiers, removing the assertions as it is not needed to check them multiple times+applyModifiers :: Exp -> [BindModifier] -> (Exp, [BindModifier])+applyModifiers =+  foldr f . (,[])+  where+    f (Ass ass txt loc) (body, modifs) =+      (Assert ass body txt loc, modifs)+    f (Att attr) (body, modifs) =+      (Attr attr body mempty, Att attr : modifs)++-- A binding that occurs in the calculation flow+data Binding+  = PatBind [SizeBinder VName] (Pat StructType) Exp+  | FunBind VName ([TypeParam], [Pat ParamType], Maybe (TypeExp Info VName), Info ResRetType, Exp)++type NormState = (([Binding], [BindModifier]), VNameSource)++-- | Main monad of this module, the state as 3 parts:+-- * the VNameSource to produce new names+-- * the [Binding] is the accumulator for the result+--   It behave a bit like a writer+-- * the [BindModifier] is the current list of modifiers to apply to the introduced bindings+--   It behave like a reader for attributes modifier, and as a state for assertion,+--   they have to be in the same list to conserve their order+-- Direct interaction with the inside state should be done with caution, that's why their+-- no instance of `MonadState`.+newtype OrderingM a = OrderingM (StateT NormState (Reader String) a)+  deriving+    (Functor, Applicative, Monad, MonadReader String, MonadState NormState)++instance MonadFreshNames OrderingM where+  getNameSource = OrderingM $ gets snd+  putNameSource = OrderingM . modify . second . const++addModifier :: BindModifier -> OrderingM ()+addModifier = OrderingM . modify . first . second . (:)++rmModifier :: OrderingM ()+rmModifier = OrderingM $ modify $ first $ second tail++addBind :: Binding -> OrderingM ()+addBind (PatBind s p e) = do+  modifs <- gets $ snd . fst+  let (e', modifs') = applyModifiers e modifs+  modify $ first $ bimap (PatBind (s <> implicit) p e' :) (const modifs')+  where+    implicit = case e of+      (AppExp _ (Info (AppRes _ ext))) -> map (`SizeBinder` mempty) ext+      _ -> []+addBind b@FunBind {} =+  OrderingM $ modify $ first $ first (b :)++runOrdering :: MonadFreshNames m => OrderingM a -> m (a, [Binding])+runOrdering (OrderingM m) =+  modifyNameSource $ mod_tup . flip runReader "tmp" . runStateT m . (([], []),)+  where+    mod_tup (a, ((binds, modifs), src)) =+      if null modifs+        then ((a, binds), src)+        else error "not all bind modifiers were freed"++naming :: String -> OrderingM a -> OrderingM a+naming s = local (const s)++-- | From now, we say an expression is "final" if it's going to be stored in a let-bind+-- or is at the end of the body e.g. after all lets++-- Replace a non-final expression by a let-binded variable+nameExp :: Bool -> Exp -> OrderingM Exp+nameExp True e = pure e+nameExp False e = do+  name <- newNameFromString =<< ask -- "e<{" ++ prettyString e ++ "}>"+  let ty = typeOf e+      loc = srclocOf e+      pat = Id name (Info ty) loc+  addBind $ PatBind [] pat e+  pure $ Var (qualName name) (Info ty) loc++-- An evocative name to use when naming subexpressions of the+-- expression bound to this pattern.+patRepName :: Pat t -> String+patRepName (PatAscription p _ _) = patRepName p+patRepName (Id v _ _) = baseString v+patRepName _ = "tmp"++expRepName :: Exp -> String+expRepName (Var v _ _) = prettyString v+expRepName e = "d<{" ++ prettyString (bareExp e) ++ "}>"++-- An evocative name to use when naming arguments to an application.+argRepName :: Exp -> Int -> String+argRepName e i = expRepName e <> "_arg" <> show i++-- Modify an expression as describe in module introduction,+-- introducing the let-bindings in the state.+getOrdering :: Bool -> Exp -> OrderingM Exp+getOrdering final (Assert ass e txt loc) = do+  ass' <- getOrdering False ass+  l_prev <- OrderingM $ gets $ length . snd . fst+  addModifier $ Ass ass' txt loc+  e' <- getOrdering final e+  l_after <- OrderingM $ gets $ length . snd . fst+  -- if the list of modifier has reduced in size, that means that+  -- all assertions as been inserted,+  -- else, we have to introduce the assertion ourself+  if l_after <= l_prev+    then pure e'+    else do+      rmModifier+      pure $ Assert ass' e' txt loc+getOrdering final (Attr attr e loc) = do+  -- propagate attribute+  addModifier $ Att attr+  e' <- getOrdering final e+  rmModifier+  pure $ Attr attr e' loc+getOrdering _ e@Literal {} = pure e+getOrdering _ e@IntLit {} = pure e+getOrdering _ e@FloatLit {} = pure e+getOrdering _ e@StringLit {} = pure e+getOrdering _ e@Hole {} = pure e -- can we still have some ?+getOrdering _ e@Var {} = pure e+getOrdering final (Parens e _) = getOrdering final e+getOrdering final (QualParens _ e _) = getOrdering final e+getOrdering _ (TupLit es loc) = do+  es' <- mapM (getOrdering False) es+  pure $ TupLit es' loc+getOrdering _ (RecordLit fs loc) = do+  fs' <- mapM f fs+  pure $ RecordLit fs' loc+  where+    f (RecordFieldExplicit n e floc) = do+      e' <- getOrdering False e+      pure $ RecordFieldExplicit n e' floc+    f field@RecordFieldImplicit {} = pure field+getOrdering _ (ArrayLit es ty loc) = do+  es' <- mapM (getOrdering False) es+  pure $ ArrayLit es' ty loc+getOrdering _ (Project n e ty loc) = do+  e' <- getOrdering False e+  pure $ Project n e' ty loc+getOrdering _ (Negate e loc) = do+  e' <- getOrdering False e+  pure $ Negate e' loc+getOrdering _ (Not e loc) = do+  e' <- getOrdering False e+  pure $ Not e' loc+getOrdering final (Constr n es ty loc) = do+  es' <- mapM (getOrdering False) es+  nameExp final $ Constr n es' ty loc+getOrdering final (Update eb slice eu loc) = do+  eu' <- getOrdering False eu+  slice' <- astMap mapper slice+  eb' <- getOrdering False eb+  nameExp final $ Update eb' slice' eu' loc+  where+    mapper = identityMapper {mapOnExp = getOrdering False}+getOrdering final (RecordUpdate eb ns eu ty loc) = do+  eb' <- getOrdering False eb+  eu' <- getOrdering False eu+  nameExp final $ RecordUpdate eb' ns eu' ty loc+getOrdering final (Lambda params body mte ret loc) = do+  body' <- transformBody body+  nameExp final $ Lambda params body' mte ret loc+getOrdering _ (OpSection qn ty loc) =+  pure $ Var qn ty loc+getOrdering final (OpSectionLeft op ty e (Info (xp, _, xext), Info (yp, yty)) (Info (RetType dims ret), Info exts) loc) = do+  x <- getOrdering False e+  yn <- newNameFromString "y"+  let y = Var (qualName yn) (Info $ toStruct yty) mempty+      ret' = applySubst (pSubst x y) ret+      body =+        mkApply (Var op ty mempty) [(Observe, xext, x), (Observe, Nothing, y)] $+          AppRes (toStruct ret') exts+  nameExp final $ Lambda [Id yn (Info yty) mempty] body Nothing (Info (RetType dims ret')) loc+  where+    pSubst x y vn+      | Named p <- xp, p == vn = Just $ ExpSubst x+      | Named p <- yp, p == vn = Just $ ExpSubst y+      | otherwise = Nothing+getOrdering final (OpSectionRight op ty e (Info (xp, xty), Info (yp, _, yext)) (Info (RetType dims ret)) loc) = do+  xn <- newNameFromString "x"+  y <- getOrdering False e+  let x = Var (qualName xn) (Info $ toStruct xty) mempty+      ret' = applySubst (pSubst x y) ret+      body = mkApply (Var op ty mempty) [(Observe, Nothing, x), (Observe, yext, y)] $ AppRes (toStruct ret') []+  nameExp final $ Lambda [Id xn (Info xty) mempty] body Nothing (Info (RetType dims ret')) loc+  where+    pSubst x y vn+      | Named p <- xp, p == vn = Just $ ExpSubst x+      | Named p <- yp, p == vn = Just $ ExpSubst y+      | otherwise = Nothing+getOrdering final (ProjectSection names (Info ty) loc) = do+  xn <- newNameFromString "x"+  let (xty, RetType dims ret) = case ty of+        Scalar (Arrow _ _ d xty' ret') -> (toParam d xty', ret')+        _ -> error $ "not a function type for project section: " ++ prettyString ty+      x = Var (qualName xn) (Info $ toStruct xty) mempty+      body = foldl project x names+  nameExp final $ Lambda [Id xn (Info xty) mempty] body Nothing (Info (RetType dims ret)) loc+  where+    project e field =+      case typeOf e of+        Scalar (Record fs)+          | Just t <- M.lookup field fs ->+              Project field e (Info t) mempty+        t ->+          error $+            "desugar ProjectSection: type "+              ++ prettyString t+              ++ " does not have field "+              ++ prettyString field+getOrdering final (IndexSection slice (Info ty) loc) = do+  slice' <- astMap mapper slice+  xn <- newNameFromString "x"+  let (xty, RetType dims ret) = case ty of+        Scalar (Arrow _ _ d xty' ret') -> (toParam d xty', ret')+        _ -> error $ "not a function type for index section: " ++ prettyString ty+      x = Var (qualName xn) (Info $ toStruct xty) mempty+      body = AppExp (Index x slice' loc) (Info (AppRes (toStruct ret) []))+  nameExp final $ Lambda [Id xn (Info xty) mempty] body Nothing (Info (RetType dims ret)) loc+  where+    mapper = identityMapper {mapOnExp = getOrdering False}+getOrdering _ (Ascript e _ _) = getOrdering False e+getOrdering final (AppExp (Apply f args loc) resT) = do+  args' <-+    NE.reverse <$> mapM onArg (NE.reverse (NE.zip args (NE.fromList [0 ..])))+  f' <- getOrdering False f+  nameExp final $ AppExp (Apply f' args' loc) resT+  where+    onArg ((d, e), i) =+      naming (argRepName f i) $ (d,) <$> getOrdering False e+getOrdering final (Coerce e te t loc) = do+  e' <- getOrdering False e+  nameExp final $ Coerce e' te t loc+getOrdering final (AppExp (Range start stride end loc) resT) = do+  start' <- getOrdering False start+  stride' <- mapM (getOrdering False) stride+  end' <- mapM (getOrdering False) end+  nameExp final $ AppExp (Range start' stride' end' loc) resT+getOrdering final (AppExp (LetPat sizes pat expr body _) _) = do+  expr' <- naming (patRepName pat) $ getOrdering True expr+  addBind $ PatBind sizes pat expr'+  getOrdering final body+getOrdering final (AppExp (LetFun vn (tparams, params, mrettype, rettype, body) e _) _) = do+  body' <- transformBody body+  addBind $ FunBind vn (tparams, params, mrettype, rettype, body')+  getOrdering final e+getOrdering final (AppExp (If cond et ef loc) resT) = do+  cond' <- getOrdering True cond+  et' <- transformBody et+  ef' <- transformBody ef+  nameExp final $ AppExp (If cond' et' ef' loc) resT+getOrdering final (AppExp (DoLoop sizes pat einit form body loc) resT) = do+  einit' <- getOrdering False einit+  form' <- case form of+    For ident e -> For ident <$> getOrdering True e+    ForIn fpat e -> ForIn fpat <$> getOrdering True e+    While e -> While <$> transformBody e+  body' <- transformBody body+  nameExp final $ AppExp (DoLoop sizes pat einit' form' body' loc) resT+getOrdering final (AppExp (BinOp (op, oloc) opT (el, Info elp) (er, Info erp) loc) (Info resT)) = do+  expr' <- case (isOr, isAnd) of+    (True, _) -> do+      el' <- naming "or_lhs" $ getOrdering True el+      er' <- naming "or_rhs" $ transformBody er+      pure $ AppExp (If el' (Literal (BoolValue True) mempty) er' loc) (Info resT)+    (_, True) -> do+      el' <- naming "and_lhs" $ getOrdering True el+      er' <- naming "and_rhs" $ transformBody er+      pure $ AppExp (If el' er' (Literal (BoolValue False) mempty) loc) (Info resT)+    (False, False) -> do+      el' <- naming (prettyString op <> "_lhs") $ getOrdering False el+      er' <- naming (prettyString op <> "_rhs") $ getOrdering False er+      pure $ mkApply (Var op opT oloc) [(Observe, elp, el'), (Observe, erp, er')] resT+  nameExp final expr'+  where+    isOr = baseName (qualLeaf op) == "||"+    isAnd = baseName (qualLeaf op) == "&&"+getOrdering final (AppExp (LetWith (Ident dest dty dloc) (Ident src sty sloc) slice e body loc) _) = do+  e' <- getOrdering False e+  slice' <- astMap mapper slice+  addBind $ PatBind [] (Id dest dty dloc) (Update (Var (qualName src) sty sloc) slice' e' loc)+  getOrdering final body+  where+    mapper = identityMapper {mapOnExp = getOrdering False}+getOrdering final (AppExp (Index e slice loc) resT) = do+  e' <- getOrdering False e+  slice' <- astMap mapper slice+  nameExp final $ AppExp (Index e' slice' loc) resT+  where+    mapper = identityMapper {mapOnExp = getOrdering False}+getOrdering final (AppExp (Match expr cs loc) resT) = do+  expr' <- getOrdering False expr+  cs' <- mapM f cs+  nameExp final $ AppExp (Match expr' cs' loc) resT+  where+    f (CasePat pat body cloc) = do+      body' <- transformBody body+      pure (CasePat pat body' cloc)++-- Transform a body, e.g. the expression of a valbind,+-- branches of an if/match...+-- Note that this is not producing an OrderingM, produce+-- a complete separtion of states.+transformBody :: MonadFreshNames m => Exp -> m Exp+transformBody e = do+  (e', pre_eval) <- runOrdering (getOrdering True e)+  pure $ foldl f e' pre_eval+  where+    appRes = case e of+      (AppExp _ r) -> r+      _ -> Info $ AppRes (typeOf e) []++    f body (PatBind sizes p expr) =+      AppExp+        ( LetPat+            sizes+            p+            expr+            body+            mempty+        )+        appRes+    f body (FunBind vn infos) =+      AppExp (LetFun vn infos body mempty) appRes++transformDec :: MonadFreshNames m => Dec -> m Dec+transformDec (ValDec valbind) = do+  body' <- transformBody $ valBindBody valbind+  pure $ ValDec (valbind {valBindBody = body'})+transformDec d = pure d++transformProg :: MonadFreshNames m => [Dec] -> m [Dec]+transformProg = mapM transformDec