futhark 0.16.4 → 0.17.1

raw patch · 223 files changed

+61586/−49496 lines, 223 filesdep +sexp-grammardep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: sexp-grammar

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• docs/language-reference.rst +18/−17
• docs/man/futhark-c.rst +4/−0
• docs/man/futhark-cuda.rst +9/−1
• docs/man/futhark-opencl.rst +8/−0
• docs/usage.rst +8/−0
• futhark.cabal +4/−1
• prelude/array.fut +17/−17
• prelude/math.fut +11/−50
• prelude/soacs.fut +7/−7
• rts/c/lock.h +1/−1
• rts/c/opencl.h +38/−3
• rts/python/opencl.py +4/−2
• src/Futhark/Actions.hs +117/−63
• src/Futhark/Analysis/Alias.hs +80/−55
• src/Futhark/Analysis/CallGraph.hs +67/−54
• src/Futhark/Analysis/DataDependencies.hs +55/−43
• src/Futhark/Analysis/HORep/MapNest.hs +121/−91
• src/Futhark/Analysis/HORep/SOAC.hs +415/−319
• src/Futhark/Analysis/Metrics.hs +63/−51
• src/Futhark/Analysis/PrimExp.hs +399/−216
• src/Futhark/Analysis/PrimExp/Convert.hs +74/−38
• src/Futhark/Analysis/PrimExp/Generalize.hs +55/−51
• src/Futhark/Analysis/PrimExp/Simplify.hs +31/−24
• src/Futhark/Analysis/Rephrase.hs +48/−45
• src/Futhark/Analysis/SymbolTable.hs +356/−246
• src/Futhark/Analysis/UsageTable.hs +58/−44
• src/Futhark/Bench.hs +195/−156
• src/Futhark/Binder.hs +116/−62
• src/Futhark/Binder/Class.hs +68/−47
• src/Futhark/CLI/Autotune.hs +283/−208
• src/Futhark/CLI/Bench.hs +342/−218
• src/Futhark/CLI/C.hs +10/−5
• src/Futhark/CLI/CUDA.hs +10/−5
• src/Futhark/CLI/Check.hs +10/−7
• src/Futhark/CLI/Datacmp.hs +19/−18
• src/Futhark/CLI/Dataset.hs +209/−151
• src/Futhark/CLI/Dev.hs +474/−337
• src/Futhark/CLI/Doc.hs +82/−67
• src/Futhark/CLI/Misc.hs +36/−32
• src/Futhark/CLI/OpenCL.hs +10/−5
• src/Futhark/CLI/Pkg.hs +191/−136
• src/Futhark/CLI/PyOpenCL.hs +23/−18
• src/Futhark/CLI/Python.hs +23/−18
• src/Futhark/CLI/Query.hs +3/−4
• src/Futhark/CLI/REPL.hs +282/−189
• src/Futhark/CLI/Run.hs +85/−63
• src/Futhark/CLI/Test.hs +422/−305
• src/Futhark/CodeGen/Backends/CCUDA.hs +153/−93
• src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +173/−123
• src/Futhark/CodeGen/Backends/COpenCL.hs +198/−126
• src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +343/−249
• src/Futhark/CodeGen/Backends/GenericC.hs +2414/−2200
• src/Futhark/CodeGen/Backends/GenericC/Options.hs +89/−52
• src/Futhark/CodeGen/Backends/GenericPython.hs +1212/−1033
• src/Futhark/CodeGen/Backends/GenericPython/AST.hs +114/−125
• src/Futhark/CodeGen/Backends/GenericPython/Definitions.hs +8/−6
• src/Futhark/CodeGen/Backends/GenericPython/Options.hs +69/−49
• src/Futhark/CodeGen/Backends/PyOpenCL.hs +328/−212
• src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +74/−45
• src/Futhark/CodeGen/Backends/SequentialC.hs +70/−59
• src/Futhark/CodeGen/Backends/SequentialPython.hs +38/−26
• src/Futhark/CodeGen/Backends/SimpleRep.hs +205/−158
• src/Futhark/CodeGen/ImpCode.hs +317/−265
• src/Futhark/CodeGen/ImpCode/Kernels.hs +139/−133
• src/Futhark/CodeGen/ImpCode/OpenCL.hs +60/−57
• src/Futhark/CodeGen/ImpCode/Sequential.hs +9/−10
• src/Futhark/CodeGen/ImpGen.hs +1736/−1418
• src/Futhark/CodeGen/ImpGen/CUDA.hs +5/−5
• src/Futhark/CodeGen/ImpGen/Kernels.hs +243/−226
• src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +1696/−1511
• src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +1143/−979
• src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs +37/−39
• src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +547/−381
• src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +344/−258
• src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +421/−351
• src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +327/−210
• src/Futhark/CodeGen/ImpGen/OpenCL.hs +5/−5
• src/Futhark/CodeGen/ImpGen/Sequential.hs +10/−8
• src/Futhark/CodeGen/ImpGen/Transpose.hs +214/−0
• src/Futhark/CodeGen/OpenCL/Heuristics.hs +31/−32
• src/Futhark/CodeGen/SetDefaultSpace.hs +49/−30
• src/Futhark/Compiler.hs +80/−65
• src/Futhark/Compiler/CLI.hs +140/−93
• src/Futhark/Compiler/Program.hs +139/−101
• src/Futhark/Construct.hs +321/−216
• src/Futhark/Doc/Generator.hs +414/−322
• src/Futhark/Error.hs +20/−20
• src/Futhark/FreshNames.hs +10/−8
• src/Futhark/IR.hs +8/−7
• src/Futhark/IR/Aliases.hs +248/−175
• src/Futhark/IR/Decorations.hs +64/−15
• src/Futhark/IR/Kernels.hs +26/−22
• src/Futhark/IR/Kernels/Kernel.hs +171/−111
• src/Futhark/IR/Kernels/Simplify.hs +50/−42
• src/Futhark/IR/Kernels/Sizes.hs +53/−27
• src/Futhark/IR/KernelsMem.hs +33/−32
• src/Futhark/IR/Mem.hs +1230/−1003
• src/Futhark/IR/Mem/IxFun.hs +1066/−828
• src/Futhark/IR/Mem/Simplify.hs +174/−136
• src/Futhark/IR/Pretty.hs +148/−107
• src/Futhark/IR/Primitive.hs +1714/−1366
• src/Futhark/IR/Prop.hs +125/−121
• src/Futhark/IR/Prop/Aliases.hs +75/−58
• src/Futhark/IR/Prop/Constants.hs +6/−10
• src/Futhark/IR/Prop/Names.hs +161/−112
• src/Futhark/IR/Prop/Patterns.hs +28/−25
• src/Futhark/IR/Prop/Rearrange.hs +55/−50
• src/Futhark/IR/Prop/Reshape.hs +77/−59
• src/Futhark/IR/Prop/Scope.hs +101/−67
• src/Futhark/IR/Prop/TypeOf.hs +56/−43
• src/Futhark/IR/Prop/Types.hs +228/−184
• src/Futhark/IR/RetType.hs +39/−42
• src/Futhark/IR/SOACS.hs +54/−35
• src/Futhark/IR/SOACS/SOAC.hs +584/−367
• src/Futhark/IR/SOACS/Simplify.hs +943/−808
• src/Futhark/IR/SegOp.hs +1442/−1142
• src/Futhark/IR/Seq.hs +25/−23
• src/Futhark/IR/SeqMem.hs +18/−21
• src/Futhark/IR/Syntax.hs +429/−232
• src/Futhark/IR/Syntax/Core.hs +266/−123
• src/Futhark/IR/Traversals.hs +118/−93
• src/Futhark/Internalise.hs +2181/−1900
• src/Futhark/Internalise/AccurateSizes.hs +95/−52
• src/Futhark/Internalise/Bindings.hs +81/−70
• src/Futhark/Internalise/Defunctionalise.hs +1247/−1094
• src/Futhark/Internalise/Defunctorise.hs +164/−119
• src/Futhark/Internalise/Lambdas.hs +94/−67
• src/Futhark/Internalise/Monad.hs +116/−96
• src/Futhark/Internalise/Monomorphise.hs +501/−364
• src/Futhark/Internalise/TypesValues.hs +106/−82
• src/Futhark/MonadFreshNames.hs +67/−43
• src/Futhark/Optimise/CSE.hs +175/−109
• src/Futhark/Optimise/DoubleBuffer.hs +200/−164
• src/Futhark/Optimise/Fusion.hs +1125/−980
• src/Futhark/Optimise/Fusion/Composing.hs +236/−153
• src/Futhark/Optimise/Fusion/LoopKernel.hs +941/−784
• src/Futhark/Optimise/InPlaceLowering.hs +192/−130
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +246/−183
• src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +120/−80
• src/Futhark/Optimise/InliningDeadFun.hs +203/−159
• src/Futhark/Optimise/Simplify.hs +114/−90
• src/Futhark/Optimise/Simplify/ClosedForm.hs +161/−112
• src/Futhark/Optimise/Simplify/Engine.hs +1032/−882
• src/Futhark/Optimise/Simplify/Lore.hs +158/−94
• src/Futhark/Optimise/Simplify/Rule.hs +177/−117
• src/Futhark/Optimise/Simplify/Rules.hs +1482/−1322
• src/Futhark/Optimise/Sink.hs +113/−90
• src/Futhark/Optimise/TileLoops.hs +1269/−928
• src/Futhark/Optimise/Unstream.hs +33/−29
• src/Futhark/Pass.hs +56/−48
• src/Futhark/Pass/ExpandAllocations.hs +489/−343
• src/Futhark/Pass/ExplicitAllocations.hs +1178/−973
• src/Futhark/Pass/ExplicitAllocations/Kernels.hs +116/−96
• src/Futhark/Pass/ExplicitAllocations/SegOp.hs +70/−49
• src/Futhark/Pass/ExplicitAllocations/Seq.hs +6/−5
• src/Futhark/Pass/ExtractKernels.hs +446/−376
• src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +160/−127
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +1201/−1064
• src/Futhark/Pass/ExtractKernels/Distribution.hs +377/−298
• src/Futhark/Pass/ExtractKernels/ISRWIM.hs +121/−93
• src/Futhark/Pass/ExtractKernels/Interchange.hs +82/−58
• src/Futhark/Pass/ExtractKernels/Intragroup.hs +168/−136
• src/Futhark/Pass/ExtractKernels/StreamKernel.hs +188/−117
• src/Futhark/Pass/ExtractKernels/ToKernels.hs +50/−38
• src/Futhark/Pass/FirstOrderTransform.hs +9/−9
• src/Futhark/Pass/KernelBabysitting.hs +348/−273
• src/Futhark/Pass/Simplify.hs +14/−13
• src/Futhark/Passes.hs +63/−58
• src/Futhark/Pipeline.hs +108/−86
• src/Futhark/Pkg/Info.hs +269/−159
• src/Futhark/Pkg/Solve.hs +67/−50
• src/Futhark/Pkg/Types.hs +154/−123
• src/Futhark/Test.hs +483/−364
• src/Futhark/Test/Values.hs +275/−225
• src/Futhark/Tools.hs +70/−50
• src/Futhark/Transform/CopyPropagate.hs +26/−22
• src/Futhark/Transform/FirstOrderTransform.hs +235/−172
• src/Futhark/Transform/Rename.hs +142/−98
• src/Futhark/Transform/Substitute.hs +69/−58
• src/Futhark/TypeCheck.hs +1388/−1141
• src/Futhark/Util.hs +141/−106
• src/Futhark/Util/Console.hs +6/−6
• src/Futhark/Util/IntegralExp.hs +15/−20
• src/Futhark/Util/Loc.hs +2/−1
• src/Futhark/Util/Log.hs +10/−10
• src/Futhark/Util/Options.hs +53/−39
• src/Futhark/Util/Pretty.hs +27/−25
• src/Futhark/Util/Table.hs +25/−22
• src/Futhark/Version.hs +26/−20
• src/Language/Futhark.hs +26/−13
• src/Language/Futhark/Core.hs +113/−56
• src/Language/Futhark/Interpreter.hs +1713/−1535
• src/Language/Futhark/Parser.hs +40/−32
• src/Language/Futhark/Parser/Parser.y +1/−1
• src/Language/Futhark/Prelude.hs +6/−5
• src/Language/Futhark/Pretty.hs +248/−203
• src/Language/Futhark/Prop.hs +1125/−1030
• src/Language/Futhark/Query.hs +126/−117
• src/Language/Futhark/Semantic.hs +93/−80
• src/Language/Futhark/Syntax.hs +1218/−1104
• src/Language/Futhark/Traversals.hs +184/−118
• src/Language/Futhark/TypeChecker.hs +379/−302
• src/Language/Futhark/TypeChecker/Modules.hs +385/−256
• src/Language/Futhark/TypeChecker/Monad.hs +224/−184
• src/Language/Futhark/TypeChecker/Terms.hs +3311/−3024
• src/Language/Futhark/TypeChecker/Types.hs +307/−235
• src/Language/Futhark/TypeChecker/Unify.hs +1141/−975
• src/Language/Futhark/Warnings.hs +23/−20
• src/futhark.hs +74/−77
• unittests/Futhark/BenchTests.hs +14/−10
• unittests/Futhark/IR/Mem/IxFun/Alg.hs +71/−55
• unittests/Futhark/IR/Mem/IxFunTests.hs +298/−224
• unittests/Futhark/IR/Mem/IxFunWrapper.hs +40/−22
• unittests/Futhark/IR/PrimitiveTests.hs +51/−28
• unittests/Futhark/IR/Prop/RearrangeTests.hs +32/−33
• unittests/Futhark/IR/Prop/ReshapeTests.hs +53/−49
• unittests/Futhark/IR/PropTests.hs +10/−7
• unittests/Futhark/IR/Syntax/CoreTests.hs +39/−37
• unittests/Futhark/IR/SyntaxTests.hs +2/−3
• unittests/Futhark/Pkg/SolveTests.hs +117/−82
• unittests/Language/Futhark/CoreTests.hs +4/−5
• unittests/Language/Futhark/SyntaxTests.hs +21/−21
• unittests/futhark_tests.hs +14/−14

@@ -34,12 +34,11 @@ Many things in Futhark are named. When we are defining something, we give it an unqualified name (`id`).  When referencing something inside a module, we use a qualified name (`qualid`).  The constructor names-of a sum type (:ref:`compounds`) are identifiers prefixed with ``#``,-with no space afterwards.  The fields of a record are named with-`fieldid`.  Note that a `fieldid` can be a decimal number.  Futhark-has three distinct name spaces: terms, module types, and types.-Modules (including parametric modules) and values both share the term-namespace.+of a sum type are identifiers prefixed with ``#``, with no space+afterwards.  The fields of a record are named with `fieldid`.  Note+that a `fieldid` can be a decimal number.  Futhark has three distinct+name spaces: terms, module types, and types.  Modules (including+parametric modules) and values both share the term namespace.  .. _primitives: @@ -94,8 +93,6 @@    hexdigit: `decdigit` | "a"..."f" | "A"..."F"    bindigit: "0" | "1" -.. _compounds:- Compound Types and Values ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -329,6 +326,9 @@ Any top-level function named ``main`` will always be considered an entry point, whether it is declared with ``entry`` or not. +The name of an entry point must not contain an apostrophe (``'``),+even though that is normally permitted in Futhark identifiers.+ Value Declarations ~~~~~~~~~~~~~~~~~~ @@ -594,7 +594,7 @@ Return the element at the given position in the array.  The index may be a comma-separated list of indexes instead of just a single index. If the number of indices given is less than the rank of the array, an-array is returned.+array is returned.  The index may be of any unsigned integer type.  The array ``a`` must be a variable name or a parenthesised expression. Furthermore, there *may not* be a space between ``a`` and the opening@@ -610,7 +610,8 @@ former inclusive and the latter exclusive, taking every ``s``-th element.  The ``s`` parameter may not be zero.  If ``s`` is negative, it means to start at ``i`` and descend by steps of size ``s`` to ``j``-(not inclusive).+(not inclusive).  Slicing can be done only with expressions of type+``i32``.  It is generally a bad idea for ``s`` to be non-constant. Slicing of multiple dimensions can be done by separating with commas,@@ -647,9 +648,9 @@ ``x..y...z`` ............ -Construct an integer array whose first element is ``x`` and which-proceeds stride of ``y-x`` until reaching ``z`` (inclusive).  The-``..y`` part can be elided in which case a stride of 1 is used.  A+Construct a signed integer array whose first element is ``x`` and+which proceeds stride of ``y-x`` until reaching ``z`` (inclusive).+The ``..y`` part can be elided in which case a stride of 1 is used.  A run-time error occurs if ``z`` is lesser than ``x`` or ``y``, or if ``x`` and ``y`` are the same value. @@ -666,8 +667,8 @@ ``x..y..<z`` ............ -Construct an integer array whose first elements is ``x``, and which-proceeds upwards with a stride of ``y`` until reaching ``z``+Construct a signed integer array whose first elements is ``x``, and+which proceeds upwards with a stride of ``y`` until reaching ``z`` (exclusive).  The ``..y`` part can be elided in which case a stride of 1 is used.  A run-time error occurs if ``z`` is lesser than ``x`` or ``y``, or if ``x`` and ``y`` are the same value.@@ -681,8 +682,8 @@ ``x..y..>z`` ............... -Construct an integer array whose first elements is ``x``, and which-proceeds downwards with a stride of ``y`` until reaching ``z``+Construct a signed integer array whose first elements is ``x``, and+which proceeds downwards with a stride of ``y`` until reaching ``z`` (exclusive).  The ``..y`` part can be elided in which case a stride of -1 is used.  A run-time error occurs if ``z`` is greater than ``x`` or ``y``, or if ``x`` and ``y`` are the same value.

@@ -62,6 +62,10 @@  The following options are accepted by executables generated by ``futhark c``. +-h, --help++  Print help text to standard output and exit.+ -b, --binary-output    Print the program result in the binary output format.  The default

@@ -23,10 +23,14 @@ resulting program will otherwise behave exactly as one compiled with ``futhark c``. -``futhark cuda`` uses ``-lcuda -lnvrtc`` to link.  If using+``futhark cuda`` uses ``-lcuda -lcudart -lnvrtc`` to link.  If using ``--library``, you will need to do the same when linking the final binary. +The generated CUDA code can be called from multiple CPU threads, as it+brackets every API operation with ``cuCtxPushCurrent()`` and+``cuCtxPopCurrent()``.+ OPTIONS ======= @@ -68,6 +72,10 @@ nomenclature ("group" instead of "thread block").  The following additional options are accepted.++-h, --help++  Print help text to standard output and exit.  --default-group-size=INT 

@@ -73,6 +73,10 @@  The following additional options are accepted. +-h, --help++  Print help text to standard output and exit.+ --build-option=OPT    Add an additional build option to the string passed to@@ -154,6 +158,10 @@ --tuning=FILE    Read size=value assignments from the given file.++--list-devices++  List all OpenCL devices and platforms available on the system.  SEE ALSO ========

@@ -75,6 +75,10 @@  All generated executables support the following options. +  ``-h/--help``++    Print help text to standard output and exit.+   ``-t FILE``      Print the time taken to execute the program to the indicated file,@@ -205,6 +209,10 @@     ``clBuildProgram()``.  Refer to the OpenCL documentation for which     options are supported.  Be careful - some options can easily     result in invalid results.++  ``--list-devices``++    List all OpenCL devices and platforms available on the system.  There is rarely a need to use both ``-p`` and ``-d``.  For example, to run on the first available NVIDIA GPU, ``-p NVIDIA`` is sufficient, as

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           futhark-version:        0.16.4+version:        0.17.1 synopsis:       An optimising compiler for a functional, array-oriented language.  description:    Futhark is a small programming language designed to be compiled to@@ -118,6 +118,7 @@       Futhark.CodeGen.ImpGen.Kernels.Transpose       Futhark.CodeGen.ImpGen.OpenCL       Futhark.CodeGen.ImpGen.Sequential+      Futhark.CodeGen.ImpGen.Transpose       Futhark.CodeGen.OpenCL.Heuristics       Futhark.CodeGen.SetDefaultSpace       Futhark.Compiler@@ -286,6 +287,7 @@     , process >=1.4.3.0     , process-extras >=0.7.2     , regex-tdfa >=1.2+    , sexp-grammar >= 2.2.1     , srcloc >=0.4     , template-haskell >=2.11.1     , temporary@@ -342,6 +344,7 @@     , megaparsec     , mtl     , parser-combinators+    , sexp-grammar     , tasty     , tasty-hunit     , tasty-quickcheck

@@ -24,13 +24,13 @@ let init [n] 't (x: [n]t) = x[0:n-1]  -- | Take some number of elements from the head of the array.-let take [n] 't (i: i32) (x: [n]t): [i]t = x[0:i]+let take [n] 't (i: i64) (x: [n]t): [i]t = x[0:i]  -- | Remove some number of elements from the head of the array.-let drop [n] 't (i: i32) (x: [n]t) = x[i:]+let drop [n] 't (i: i64) (x: [n]t) = x[i:]  -- | Split an array at a given position.-let split [n] 't (i: i32) (xs: [n]t): ([i]t, []t) =+let split [n] 't (i: i64) (xs: [n]t): ([i]t, []t) =   (xs[:i] :> [i]t, xs[i:])  -- | Return the elements of the array in reverse order.@@ -46,28 +46,28 @@ -- | Concatenation where the result has a predetermined size.  If the -- provided size is wrong, the function will fail with a run-time -- error.-let concat_to [n] [m] 't (k: i32) (xs: [n]t) (ys: [m]t): *[k]t = xs ++ ys :> [k]t+let 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+r] = a[x]`.-let rotate [n] 't (r: i32) (xs: [n]t): [n]t = intrinsics.rotate (r, xs) :> [n]t+let rotate [n] 't (r: i64) (xs: [n]t): [n]t = intrinsics.rotate (r, xs) :> [n]t  -- | Construct an array of consecutive integers of the given length, -- starting at 0.-let iota (n: i32): *[n]i32 =-  i32.iota n :> [n]i32+let iota (n: i64): *[n]i64 =+  0..1..<n  -- | Construct an array comprising valid indexes into some other -- array, starting at 0.-let indices [n] 't (_: [n]t) : *[n]i32 =+let indices [n] 't (_: [n]t) : *[n]i64 =   iota n  -- | Construct an array of the given length containing the given -- value.-let replicate 't (n: i32) (x: t): *[n]t =-  i32.replicate n x :> [n]t+let replicate 't (n: i64) (x: t): *[n]t =+  map (const x) (iota n)  -- | Copy a value.  The result will not alias anything. let copy 't (a: t): *t =@@ -79,7 +79,7 @@  -- | Like `flatten`@term, but where the final size is known.  Fails at -- runtime if the provided size is wrong.-let flatten_to [n][m] 't (l: i32) (xs: [n][m]t): [l]t =+let flatten_to [n][m] 't (l: i64) (xs: [n][m]t): [l]t =   flatten xs :> [l]t  -- | Combines the outer three dimensions of an array.@@ -91,15 +91,15 @@   flatten (flatten_3d xs)  -- | Splits the outer dimension of an array in two.-let unflatten [p] 't (n: i32) (m: i32) (xs: [p]t): [n][m]t =+let unflatten [p] 't (n: i64) (m: i64) (xs: [p]t): [n][m]t =   intrinsics.unflatten (n, m, xs) :> [n][m]t  -- | Splits the outer dimension of an array in three.-let unflatten_3d [p] 't (n: i32) (m: i32) (l: i32) (xs: [p]t): [n][m][l]t =+let 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)  -- | Splits the outer dimension of an array in four.-let unflatten_4d [p] 't (n: i32) (m: i32) (l: i32) (k: i32) (xs: [p]t): [n][m][l][k]t =+let 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)  let transpose [n] [m] 't (a: [n][m]t): [m][n]t =@@ -122,13 +122,13 @@   foldl (flip f) acc (reverse bs)  -- | Create a value for each point in a one-dimensional index space.-let tabulate 'a (n: i32) (f: i32 -> a): *[n]a =+let tabulate 'a (n: i64) (f: i64 -> a): *[n]a =   map1 f (iota n)  -- | Create a value for each point in a two-dimensional index space.-let tabulate_2d 'a (n: i32) (m: i32) (f: i32 -> i32 -> a): *[n][m]a =+let tabulate_2d 'a (n: i64) (m: i64) (f: i64 -> i64 -> a): *[n][m]a =   map1 (f >-> tabulate m) (iota n)  -- | Create a value for each point in a three-dimensional index space.-let tabulate_3d 'a (n: i32) (m: i32) (o: i32) (f: i32 -> i32 -> i32 -> a): *[n][m][o]a =+let tabulate_3d 'a (n: i64) (m: i64) (o: i64) (f: i64 -> i64 -> i64 -> a): *[n][m][o]a =   map1 (f >-> tabulate_2d m o) (iota n)

@@ -2,8 +2,6 @@  import "soacs" -local let const 'a 'b (x: a) (_: b): a = x- -- | Describes types of values that can be created from the primitive -- numeric types (and bool). module type from_prim = {@@ -118,22 +116,11 @@   val ctz: t -> i32 } --- | An extension of `size`@mtype that further includes facilities for--- constructing arrays where the size is provided as a value of the--- given integral type.-module type size = {-  include integral--  val iota: t -> *[]t-  val replicate 'v: t -> v -> *[]v-}- -- | Numbers that model real numbers to some degree. module type real = {   include numeric -  val from_fraction: i32 -> i32 -> t-  val to_i32: t -> i32+  val from_fraction: i64 -> i64 -> t   val to_i64: t -> i64   val to_f64: t -> f64 @@ -239,7 +226,7 @@   let bool (x: bool) = x } -module i8: (size with t = i8) = {+module i8: (integral with t = i8) = {   type t = i8    let (x: i8) + (y: i8) = intrinsics.add8 (x, y)@@ -305,16 +292,13 @@   let clz = intrinsics.clz8   let ctz = intrinsics.ctz8 -  let iota (n: i8) = 0i8..1i8..<n-  let replicate 'v (n: i8) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest   let minimum = reduce min highest } -module i16: (size with t = i16) = {+module i16: (integral with t = i16) = {   type t = i16    let (x: i16) + (y: i16) = intrinsics.add16 (x, y)@@ -380,16 +364,13 @@   let clz = intrinsics.clz16   let ctz = intrinsics.ctz16 -  let iota (n: i16) = 0i16..1i16..<n-  let replicate 'v (n: i16) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest   let minimum = reduce min highest } -module i32: (size with t = i32) = {+module i32: (integral with t = i32) = {   type t = i32    let sign (x: u32) = intrinsics.sign_i32 x@@ -458,16 +439,13 @@   let clz = intrinsics.clz32   let ctz = intrinsics.ctz32 -  let iota (n: i32) = 0..1..<n-  let replicate 'v (n: i32) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest   let minimum = reduce min highest } -module i64: (size with t = i64) = {+module i64: (integral with t = i64) = {   type t = i64    let sign (x: u64) = intrinsics.sign_i64 x@@ -536,16 +514,13 @@   let clz = intrinsics.clz64   let ctz = intrinsics.ctz64 -  let iota (n: i64) = 0i64..1i64..<n-  let replicate 'v (n: i64) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest   let minimum = reduce min highest } -module u8: (size with t = u8) = {+module u8: (integral with t = u8) = {   type t = u8    let sign (x: u8) = intrinsics.sign_i8 x@@ -614,16 +589,13 @@   let clz x = intrinsics.clz8 (sign x)   let ctz x = intrinsics.ctz8 (sign x) -  let iota (n: u8) = 0u8..1u8..<n-  let replicate 'v (n: u8) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest   let minimum = reduce min highest } -module u16: (size with t = u16) = {+module u16: (integral with t = u16) = {   type t = u16    let sign (x: u16) = intrinsics.sign_i16 x@@ -692,16 +664,13 @@   let clz x = intrinsics.clz16 (sign x)   let ctz x = intrinsics.ctz16 (sign x) -  let iota (n: u16) = 0u16..1u16..<n-  let replicate 'v (n: u16) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest   let minimum = reduce min highest } -module u32: (size with t = u32) = {+module u32: (integral with t = u32) = {   type t = u32    let sign (x: u32) = intrinsics.sign_i32 x@@ -770,16 +739,13 @@   let clz x = intrinsics.clz32 (sign x)   let ctz x = intrinsics.ctz32 (sign x) -  let iota (n: u32) = 0u32..1u32..<n-  let replicate 'v (n: u32) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest   let minimum = reduce min highest } -module u64: (size with t = u64) = {+module u64: (integral with t = u64) = {   type t = u64    let sign (x: u64) = intrinsics.sign_i64 x@@ -848,9 +814,6 @@   let clz x = intrinsics.clz64 (sign x)   let ctz x = intrinsics.ctz64 (sign x) -  let iota (n: u64) = 0u64..1u64..<n-  let replicate 'v (n: u64) (x: v) = map (const x) (iota n)-   let sum = reduce (+) (i32 0)   let product = reduce (*) (i32 1)   let maximum = reduce max lowest@@ -886,8 +849,7 @@    let bool (x: bool) = if x then 1f64 else 0f64 -  let from_fraction (x: i32) (y: i32) = i32 x / i32 y-  let to_i32 (x: f64) = intrinsics.fptosi_f64_i32 x+  let from_fraction (x: i64) (y: i64) = i64 x / i64 y   let to_i64 (x: f64) = intrinsics.fptosi_f64_i64 x   let to_f64 (x: f64) = x @@ -994,8 +956,7 @@    let bool (x: bool) = if x then 1f32 else 0f32 -  let from_fraction (x: i32) (y: i32) = i32 x / i32 y-  let to_i32 (x: f32) = intrinsics.fptosi_f32_i32 x+  let from_fraction (x: i64) (y: i64) = i64 x / i64 y   let to_i64 (x: f32) = intrinsics.fptosi_f32_i64 x   let to_f64 (x: f32) = intrinsics.fpconv_f32_f64 x 

@@ -118,7 +118,7 @@ -- -- In practice, the *O(n)* behaviour only occurs if *m* is also very -- large.-let reduce_by_index 'a [m] [n] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i32) (as : [n]a) : *[m]a =+let reduce_by_index 'a [m] [n] (dest : *[m]a) (f : a -> a -> a) (ne : a) (is : [n]i64) (as : [n]a) : *[m]a =   intrinsics.hist (1, dest, f, ne, is, as) :> *[m]a  -- | Inclusive prefix scan.  Has the same caveats with respect to@@ -163,7 +163,7 @@  -- | `reduce_stream op f as` splits `as` into chunks, applies `f` to each -- of these in parallel, and uses `op` (which must be associative) to--- combine the per-chunk results into a final result.  The `i32`+-- combine the per-chunk results into a final result.  The `i64` -- passed to `f` is the size of the chunk.  This SOAC is useful when -- `f` can be given a particularly work-efficient sequential -- implementation.  Operationally, we can imagine that `as` is divided@@ -176,7 +176,7 @@ -- **Work:** *O(n)* -- -- **Span:** *O(log(n))*-let reduce_stream [n] 'a 'b (op: b -> b -> b) (f: (k: i32) -> [k]a -> b) (as: [n]a): b =+let reduce_stream [n] 'a 'b (op: b -> b -> b) (f: (k: i64) -> [k]a -> b) (as: [n]a): b =   intrinsics.reduce_stream (op, f, as)  -- | As `reduce_stream`@term, but the chunks do not necessarily@@ -186,7 +186,7 @@ -- **Work:** *O(n)* -- -- **Span:** *O(log(n))*-let reduce_stream_per [n] 'a 'b (op: b -> b -> b) (f: (k: i32) -> [k]a -> b) (as: [n]a): b =+let reduce_stream_per [n] 'a 'b (op: b -> b -> b) (f: (k: i64) -> [k]a -> b) (as: [n]a): b =   intrinsics.reduce_stream_per (op, f, as)  -- | Similar to `reduce_stream`@term, except that each chunk must produce@@ -196,7 +196,7 @@ -- **Work:** *O(n)* -- -- **Span:** *O(1)*-let map_stream [n] 'a 'b (f: (k: i32) -> [k]a -> [k]b) (as: [n]a): *[n]b =+let map_stream [n] 'a 'b (f: (k: i64) -> [k]a -> [k]b) (as: [n]a): *[n]b =   intrinsics.map_stream (f, as) :> *[n]b  -- | Similar to `map_stream`@term, but the chunks do not necessarily@@ -206,7 +206,7 @@ -- **Work:** *O(n)* -- -- **Span:** *O(1)*-let map_stream_per [n] 'a 'b (f: (k: i32) -> [k]a -> [k]b) (as: [n]a): *[n]b =+let map_stream_per [n] 'a 'b (f: (k: i64) -> [k]a -> [k]b) (as: [n]a): *[n]b =   intrinsics.map_stream_per (f, as) :> *[n]b  -- | Return `true` if the given function returns `true` for all@@ -252,5 +252,5 @@ -- **Work:** *O(n)* -- -- **Span:** *O(1)*-let scatter 't [m] [n] (dest: *[m]t) (is: [n]i32) (vs: [n]t): *[m]t =+let scatter 't [m] [n] (dest: *[m]t) (is: [n]i64) (vs: [n]t): *[m]t =   intrinsics.scatter (dest, is, vs) :> *[m]t

@@ -11,7 +11,7 @@  typedef HANDLE lock_t; -static lock_t create_lock(lock_t *lock) {+static void create_lock(lock_t *lock) {   *lock = CreateMutex(NULL,  // Default security attributes.                       FALSE, // Initially unlocked.                       NULL); // Unnamed.

@@ -342,6 +342,33 @@ }  // Returns 0 on success.+static int list_devices(struct opencl_config *cfg) {+  struct opencl_device_option *devices;+  size_t num_devices;++  opencl_all_device_options(&devices, &num_devices);++  const char *cur_platform = "";+  for (size_t i = 0; i < num_devices; i++) {+    struct opencl_device_option device = devices[i];+    if (strcmp(cur_platform, device.platform_name) != 0) {+      printf("Platform: %s\n", device.platform_name);+      cur_platform = device.platform_name;+    }+    printf("[%d]: %s\n", (int)i, device.device_name);+  }++  // Free all the platform and device names.+  for (size_t j = 0; j < num_devices; j++) {+    free(devices[j].platform_name);+    free(devices[j].device_name);+  }+  free(devices);++  return 0;+}++// Returns 0 on success. static int select_device_interactively(struct opencl_config *cfg) {   struct opencl_device_option *devices;   size_t num_devices;@@ -529,11 +556,18 @@   // Futhark reserves 4 bytes for bookkeeping information.   max_local_memory -= 4; -  // NVIDIA reserves some more bytes for who-knows-what.  The number-  // of bytes here has been experimentally determined, but the-  // overhead seems to vary a bit depending on what the kernel does.+  // The OpenCL implementation may reserve some local memory bytes for+  // various purposes.  In principle, we should use+  // clGetKernelWorkGroupInfo() to figure out for each kernel how much+  // is actually available, but our current code generator design+  // makes this infeasible.  Instead, we have this nasty hack where we+  // arbitrarily subtract some bytes, based on empirical measurements+  // (but which might be arbitrarily wrong).  Fortunately, we rarely+  // try to really push the local memory usage.   if (strstr(device_option.platform_name, "NVIDIA CUDA") != NULL) {     max_local_memory -= 12;+  } else if (strstr(device_option.platform_name, "AMD") != NULL) {+    max_local_memory -= 16;   }    // Make sure this function is defined.@@ -843,6 +877,7 @@ }  static int opencl_alloc(struct opencl_context *ctx, size_t min_size, const char *tag, cl_mem *mem_out) {+  (void)tag;   if (min_size < sizeof(int)) {     min_size = sizeof(int);   }

@@ -115,12 +115,14 @@     # See comment in rts/c/opencl.h.     if self.platform.name.find('NVIDIA CUDA') >= 0:         self.max_local_memory -= 12+    elif self.platform.name.find('AMD') >= 0:+        self.max_local_memory -= 16      self.free_list = {}      self.global_failure = self.pool.allocate(np.int32().itemsize)     cl.enqueue_fill_buffer(self.queue, self.global_failure, np.int32(-1), 0, np.int32().itemsize)-    self.global_failure_args = self.pool.allocate(np.int32().itemsize *+    self.global_failure_args = self.pool.allocate(np.int64().itemsize *                                                   (self.global_failure_args_max+1))     self.failure_is_an_option = np.int32(0) @@ -223,7 +225,7 @@         cl.enqueue_fill_buffer(self.queue, self.global_failure, np.int32(-1), 0, np.int32().itemsize)          # Read failure args.-        failure_args = np.empty(self.global_failure_args_max+1, dtype=np.int32)+        failure_args = np.empty(self.global_failure_args_max+1, dtype=np.int64)         cl.enqueue_copy(self.queue, failure_args, self.global_failure_args, is_blocking=True)          raise Exception(self.failure_msgs[failure[0]].format(*failure_args))

@@ -1,75 +1,106 @@ {-# LANGUAGE FlexibleContexts #-}+ -- | All (almost) compiler pipelines end with an 'Action', which does -- something with the result of the pipeline. module Futhark.Actions-  ( printAction-  , impCodeGenAction-  , kernelImpCodeGenAction-  , metricsAction-  , compileCAction-  , compileOpenCLAction-  , compileCUDAAction+  ( printAction,+    impCodeGenAction,+    kernelImpCodeGenAction,+    metricsAction,+    compileCAction,+    compileOpenCLAction,+    compileCUDAAction,+    sexpAction,   ) where  import Control.Monad import Control.Monad.IO.Class-import System.Exit-import System.FilePath-import qualified System.Info--import Futhark.Compiler.CLI+import qualified Data.ByteString.Lazy.Char8 as ByteString import Futhark.Analysis.Alias+import Futhark.Analysis.Metrics+import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA+import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL+import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC+import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels+import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGenSequential+import Futhark.Compiler.CLI import Futhark.IR-import Futhark.IR.Prop.Aliases import Futhark.IR.KernelsMem (KernelsMem)+import Futhark.IR.Prop.Aliases import Futhark.IR.SeqMem (SeqMem)-import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGenSequential-import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels-import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC-import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA-import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL-import Futhark.Analysis.Metrics import Futhark.Util (runProgramWithExitCode)+import Language.SexpGrammar as Sexp+import System.Exit+import System.FilePath+import qualified System.Info  -- | Print the result to stdout, with alias annotations. printAction :: (ASTLore lore, CanBeAliased (Op lore)) => Action lore printAction =-  Action { actionName = "Prettyprint"-         , actionDescription = "Prettyprint the resulting internal representation on standard output."-         , actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis-         }+  Action+    { actionName = "Prettyprint",+      actionDescription = "Prettyprint the resulting internal representation on standard output.",+      actionProcedure = liftIO . putStrLn . pretty . aliasAnalysis+    }  -- | Print metrics about AST node counts to stdout. metricsAction :: OpMetrics (Op lore) => Action lore metricsAction =-  Action { actionName = "Compute metrics"-         , actionDescription = "Print metrics on the final AST."-         , actionProcedure = liftIO . putStr . show . progMetrics-         }+  Action+    { actionName = "Compute metrics",+      actionDescription = "Print metrics on the final AST.",+      actionProcedure = liftIO . putStr . show . progMetrics+    }  -- | Convert the program to sequential ImpCode and print it to stdout. impCodeGenAction :: Action SeqMem impCodeGenAction =-  Action { actionName = "Compile imperative"-         , actionDescription = "Translate program into imperative IL and write it on standard output."-         , actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenSequential.compileProg-         }+  Action+    { actionName = "Compile imperative",+      actionDescription = "Translate program into imperative IL and write it on standard output.",+      actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenSequential.compileProg+    }  -- | Convert the program to GPU ImpCode and print it to stdout. kernelImpCodeGenAction :: Action KernelsMem kernelImpCodeGenAction =-  Action { actionName = "Compile imperative kernels"-         , actionDescription = "Translate program into imperative IL with kernels and write it on standard output."-         , actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenKernels.compileProgOpenCL-         }+  Action+    { actionName = "Compile imperative kernels",+      actionDescription = "Translate program into imperative IL with kernels and write it on standard output.",+      actionProcedure = liftIO . putStrLn . pretty . snd <=< ImpGenKernels.compileProgOpenCL+    } +-- | Print metrics about AST node counts to stdout.+sexpAction :: ASTLore lore => Action lore+sexpAction =+  Action+    { actionName = "Print sexps",+      actionDescription = "Print sexps on the final IR.",+      actionProcedure = liftIO . helper+    }+  where+    helper :: ASTLore lore => Prog lore -> IO ()+    helper prog =+      case encodePretty prog of+        Right prog' -> do+          ByteString.putStrLn prog'+          let prog'' = decode prog'+          unless (prog'' == Right prog) $+            error $+              "S-exp not isomorph!\n"+                ++ either show pretty prog''+        Left s ->+          error $ "Couldn't encode program: " ++ s+ -- | The @futhark c@ action. compileCAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem compileCAction fcfg mode outpath =-  Action { actionName = "Compile to OpenCL"-         , actionDescription = "Compile to OpenCL"-         , actionProcedure = helper }+  Action+    { actionName = "Compile to OpenCL",+      actionDescription = "Compile to OpenCL",+      actionProcedure = helper+    }   where     helper prog = do       cprog <- handleWarnings fcfg $ SequentialC.compileProg prog@@ -83,23 +114,32 @@           liftIO $ writeFile cpath impl         ToExecutable -> do           liftIO $ writeFile cpath $ SequentialC.asExecutable cprog-          ret <- liftIO $ runProgramWithExitCode "gcc"-                 [cpath, "-O3", "-std=c99", "-lm", "-o", outpath] mempty+          ret <-+            liftIO $+              runProgramWithExitCode+                "gcc"+                [cpath, "-O3", "-std=c99", "-lm", "-o", outpath]+                mempty           case ret of             Left err ->               externalErrorS $ "Failed to run gcc: " ++ show err             Right (ExitFailure code, _, gccerr) ->-              externalErrorS $ "gcc failed with code " ++-              show code ++ ":\n" ++ gccerr+              externalErrorS $+                "gcc failed with code "+                  ++ show code+                  ++ ":\n"+                  ++ gccerr             Right (ExitSuccess, _, _) ->               return ()  -- | The @futhark opencl@ action. compileOpenCLAction :: FutharkConfig -> CompilerMode -> FilePath -> Action KernelsMem compileOpenCLAction fcfg mode outpath =-  Action { actionName = "Compile to OpenCL"-         , actionDescription = "Compile to OpenCL"-         , actionProcedure = helper }+  Action+    { actionName = "Compile to OpenCL",+      actionDescription = "Compile to OpenCL",+      actionProcedure = helper+    }   where     helper prog = do       cprog <- handleWarnings fcfg $ COpenCL.compileProg prog@@ -107,11 +147,11 @@           hpath = outpath `addExtension` "h"           extra_options             | System.Info.os == "darwin" =-                ["-framework", "OpenCL"]+              ["-framework", "OpenCL"]             | System.Info.os == "mingw32" =-                ["-lOpenCL64"]+              ["-lOpenCL64"]             | otherwise =-                ["-lOpenCL"]+              ["-lOpenCL"]        case mode of         ToLibrary -> do@@ -120,32 +160,42 @@           liftIO $ writeFile cpath impl         ToExecutable -> do           liftIO $ writeFile cpath $ COpenCL.asExecutable cprog-          ret <- liftIO $ runProgramWithExitCode "gcc"-                 ([cpath, "-O", "-std=c99", "-lm", "-o", outpath] ++ extra_options) mempty+          ret <-+            liftIO $+              runProgramWithExitCode+                "gcc"+                ([cpath, "-O", "-std=c99", "-lm", "-o", outpath] ++ extra_options)+                mempty           case ret of             Left err ->               externalErrorS $ "Failed to run gcc: " ++ show err             Right (ExitFailure code, _, gccerr) ->-              externalErrorS $ "gcc failed with code " ++-              show code ++ ":\n" ++ gccerr+              externalErrorS $+                "gcc failed with code "+                  ++ show code+                  ++ ":\n"+                  ++ gccerr             Right (ExitSuccess, _, _) ->               return ()  -- | The @futhark cuda@ action. compileCUDAAction :: FutharkConfig -> CompilerMode -> FilePath -> Action KernelsMem compileCUDAAction fcfg mode outpath =-  Action { actionName = "Compile to CUDA"-         , actionDescription = "Compile to CUDA"-         , actionProcedure = helper }+  Action+    { actionName = "Compile to CUDA",+      actionDescription = "Compile to CUDA",+      actionProcedure = helper+    }   where     helper prog = do       cprog <- handleWarnings fcfg $ CCUDA.compileProg prog       let cpath = outpath `addExtension` "c"           hpath = outpath `addExtension` "h"-          extra_options = [ "-lcuda"-                          , "-lcudart"-                          , "-lnvrtc"-                          ]+          extra_options =+            [ "-lcuda",+              "-lcudart",+              "-lnvrtc"+            ]       case mode of         ToLibrary -> do           let (header, impl) = CCUDA.asLibrary cprog@@ -153,14 +203,18 @@           liftIO $ writeFile cpath impl         ToExecutable -> do           liftIO $ writeFile cpath $ CCUDA.asExecutable cprog-          let args = [cpath, "-O", "-std=c99", "-lm", "-o", outpath]-                     ++ extra_options+          let args =+                [cpath, "-O", "-std=c99", "-lm", "-o", outpath]+                  ++ extra_options           ret <- liftIO $ runProgramWithExitCode "gcc" args mempty           case ret of             Left err ->               externalErrorS $ "Failed to run gcc: " ++ show err             Right (ExitFailure code, _, gccerr) ->-              externalErrorS $ "gcc failed with code " ++-              show code ++ ":\n" ++ gccerr+              externalErrorS $+                "gcc failed with code "+                  ++ show code+                  ++ ":\n"+                  ++ gccerr             Right (ExitSuccess, _, _) ->               return ()

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+ -- | Alias analysis of a full Futhark program.  Takes as input a -- program with an arbitrary lore and produces one with aliases.  This -- module does not implement the aliasing logic itself, and derives@@ -8,102 +9,126 @@ -- here will include transitive aliases (note that this is not what -- the building blocks do). module Futhark.Analysis.Alias-       ( aliasAnalysis-         -- * Ad-hoc utilities-       , AliasTable-       , analyseFun-       , analyseStms-       , analyseExp-       , analyseBody-       , analyseLambda-       )-       where+  ( aliasAnalysis, +    -- * Ad-hoc utilities+    AliasTable,+    analyseFun,+    analyseStms,+    analyseExp,+    analyseBody,+    analyseLambda,+  )+where+ import Data.List (foldl') import qualified Data.Map as M--import Futhark.IR.Syntax import Futhark.IR.Aliases  -- | Perform alias analysis on a Futhark program.-aliasAnalysis :: (ASTLore lore, CanBeAliased (Op lore)) =>-                 Prog lore -> Prog (Aliases lore)+aliasAnalysis ::+  (ASTLore lore, CanBeAliased (Op lore)) =>+  Prog lore ->+  Prog (Aliases lore) aliasAnalysis (Prog consts funs) =   Prog (fst (analyseStms mempty consts)) (map analyseFun funs) -analyseFun :: (ASTLore lore, CanBeAliased (Op lore)) =>-              FunDef lore -> FunDef (Aliases lore)+analyseFun ::+  (ASTLore lore, CanBeAliased (Op lore)) =>+  FunDef lore ->+  FunDef (Aliases lore) analyseFun (FunDef entry attrs fname restype params body) =   FunDef entry attrs fname restype params body'-  where body' = analyseBody mempty body+  where+    body' = analyseBody mempty body  -- | Pre-existing aliases for variables.  Used to add transitive -- aliases. type AliasTable = M.Map VName Names -analyseBody :: (ASTLore lore,-                CanBeAliased (Op lore)) =>-               AliasTable -> Body lore -> Body (Aliases lore)+analyseBody ::+  ( ASTLore lore,+    CanBeAliased (Op lore)+  ) =>+  AliasTable ->+  Body lore ->+  Body (Aliases lore) analyseBody atable (Body lore stms result) =   let (stms', _atable') = analyseStms atable stms-  in mkAliasedBody lore stms' result+   in mkAliasedBody lore stms' result -analyseStms :: (ASTLore lore, CanBeAliased (Op lore)) =>-               AliasTable -> Stms lore -> (Stms (Aliases lore), AliasesAndConsumed)+analyseStms ::+  (ASTLore lore, CanBeAliased (Op lore)) =>+  AliasTable ->+  Stms lore ->+  (Stms (Aliases lore), AliasesAndConsumed) analyseStms orig_aliases =   foldl' f (mempty, (orig_aliases, mempty)) . stmsToList-  where f (stms, aliases) stm =-          let stm' = analyseStm (fst aliases) stm-              atable' = trackAliases aliases stm'-          in (stms<>oneStm stm', atable')+  where+    f (stms, aliases) stm =+      let stm' = analyseStm (fst aliases) stm+          atable' = trackAliases aliases stm'+       in (stms <> oneStm stm', atable') -analyseStm :: (ASTLore lore, CanBeAliased (Op lore)) =>-              AliasTable -> Stm lore -> Stm (Aliases lore)+analyseStm ::+  (ASTLore lore, CanBeAliased (Op lore)) =>+  AliasTable ->+  Stm lore ->+  Stm (Aliases lore) analyseStm aliases (Let pat (StmAux cs attrs dec) e) =   let e' = analyseExp aliases e       pat' = addAliasesToPattern pat e'       lore' = (AliasDec $ consumedInExp e', dec)-  in Let pat' (StmAux cs attrs lore') e'--analyseExp :: (ASTLore lore, CanBeAliased (Op lore)) =>-              AliasTable -> Exp lore -> Exp (Aliases lore)+   in Let pat' (StmAux cs attrs lore') e' +analyseExp ::+  (ASTLore lore, CanBeAliased (Op lore)) =>+  AliasTable ->+  Exp lore ->+  Exp (Aliases lore) -- Would be better to put this in a BranchType annotation, but that -- requires a lot of other work. analyseExp aliases (If cond tb fb dec) =   let Body ((tb_als, tb_cons), tb_dec) tb_stms tb_res = analyseBody aliases tb       Body ((fb_als, fb_cons), fb_dec) fb_stms fb_res = analyseBody aliases fb       cons = tb_cons <> fb_cons-      isConsumed v = any (`nameIn` unAliases cons) $-                     v : namesToList (M.findWithDefault mempty v aliases)-      notConsumed = AliasDec . namesFromList .-                    filter (not . isConsumed) .-                    namesToList . unAliases+      isConsumed v =+        any (`nameIn` unAliases cons) $+          v : namesToList (M.findWithDefault mempty v aliases)+      notConsumed =+        AliasDec . namesFromList+          . filter (not . isConsumed)+          . namesToList+          . unAliases       tb_als' = map notConsumed tb_als       fb_als' = map notConsumed fb_als       tb' = Body ((tb_als', tb_cons), tb_dec) tb_stms tb_res       fb' = Body ((fb_als', fb_cons), fb_dec) fb_stms fb_res-  in If cond tb' fb' dec-+   in If cond tb' fb' dec analyseExp aliases e = mapExp analyse e-  where analyse =-          Mapper { mapOnSubExp = return-                 , mapOnVName = return-                 , mapOnBody = const $ return . analyseBody aliases-                 , mapOnRetType = return-                 , mapOnBranchType = return-                 , mapOnFParam = return-                 , mapOnLParam = return-                 , mapOnOp = return . addOpAliases-                 }+  where+    analyse =+      Mapper+        { mapOnSubExp = return,+          mapOnVName = return,+          mapOnBody = const $ return . analyseBody aliases,+          mapOnRetType = return,+          mapOnBranchType = return,+          mapOnFParam = return,+          mapOnLParam = return,+          mapOnOp = return . addOpAliases+        } -analyseLambda :: (ASTLore lore, CanBeAliased (Op lore)) =>-                 Lambda lore -> Lambda (Aliases lore)+analyseLambda ::+  (ASTLore lore, CanBeAliased (Op lore)) =>+  Lambda lore ->+  Lambda (Aliases lore) analyseLambda lam =   -- XXX: it may cause trouble that we pass mempty to analyseBody   -- here.  However, fixing this generally involves adding an   -- AliasTable argument to addOpAliases.   let body = analyseBody mempty $ lambdaBody lam-  in lam { lambdaBody = body-         , lambdaParams = lambdaParams lam-         }+   in lam+        { lambdaBody = body,+          lambdaParams = lambdaParams lam+        }

@@ -1,30 +1,31 @@ {-# LANGUAGE OverloadedStrings #-}+ -- | This module exports functionality for generating a call graph of -- an Futhark program. module Futhark.Analysis.CallGraph-  ( CallGraph-  , buildCallGraph-  , isFunInCallGraph-  , calls-  , calledByConsts-  , allCalledBy-  , findNoninlined+  ( CallGraph,+    buildCallGraph,+    isFunInCallGraph,+    calls,+    calledByConsts,+    allCalledBy,+    findNoninlined,   )-  where+where  import Control.Monad.Writer.Strict+import Data.List (foldl') import qualified Data.Map.Strict as M-import qualified Data.Set as S import Data.Maybe (fromMaybe)-import Data.List (foldl')-+import qualified Data.Set as S import Futhark.IR.SOACS  type FunctionTable = M.Map Name (FunDef SOACS)  buildFunctionTable :: Prog SOACS -> FunctionTable buildFunctionTable = foldl expand M.empty . progFuns-  where expand ftab f = M.insert (funDefName f) f ftab+  where+    expand ftab f = M.insert (funDefName f) f ftab  type FunGraph = M.Map Name (S.Set Name) @@ -33,9 +34,10 @@ -- transitively!) by the function. -- -- We keep track separately of the functions called by constants.-data CallGraph = CallGraph { calledByFuns :: M.Map Name (S.Set Name)-                           , calledInConsts :: S.Set Name-                           }+data CallGraph = CallGraph+  { calledByFuns :: M.Map Name (S.Set Name),+    calledInConsts :: S.Set Name+  }  -- | Is the given function known to the call graph? isFunInCallGraph :: Name -> CallGraph -> Bool@@ -58,23 +60,24 @@ buildCallGraph :: Prog SOACS -> CallGraph buildCallGraph prog =   CallGraph fg $ buildFGStms $ progConsts prog-  where fg = foldl' (buildFGfun ftable) M.empty entry_points+  where+    fg = foldl' (buildFGfun ftable) M.empty entry_points -        entry_points = map funDefName $ progFuns prog-        ftable = buildFunctionTable prog+    entry_points = map funDefName $ progFuns prog+    ftable = buildFunctionTable prog  -- | @buildCallGraph ftable fg fname@ updates @fg@ with the -- contributions of function @fname@. buildFGfun :: FunctionTable -> FunGraph -> Name -> FunGraph-buildFGfun ftable fg fname  =+buildFGfun ftable fg fname =   -- Check if function is a non-builtin that we have not already   -- processed.   case M.lookup fname ftable of     Just f | Nothing <- M.lookup fname fg -> do-               let callees = buildFGBody $ funDefBody f-                   fg' = M.insert fname callees fg-               -- recursively build the callees-               foldl' (buildFGfun ftable) fg' callees+      let callees = buildFGBody $ funDefBody f+          fg' = M.insert fname callees fg+      -- recursively build the callees+      foldl' (buildFGfun ftable) fg' callees     _ -> fg  buildFGStms :: Stms SOACS -> S.Set Name@@ -86,41 +89,51 @@ buildFGexp :: Exp -> S.Set Name buildFGexp (Apply fname _ _ _) = S.singleton fname buildFGexp (Op op) = execWriter $ mapSOACM folder op-  where folder = identitySOACMapper {-          mapOnSOACLambda = \lam -> do tell $ buildFGBody $ lambdaBody lam-                                       return lam-          }+  where+    folder =+      identitySOACMapper+        { mapOnSOACLambda = \lam -> do+            tell $ buildFGBody $ lambdaBody lam+            return lam+        } buildFGexp e = execWriter $ mapExpM folder e-  where folder = identityMapper {-          mapOnBody = \_ body -> do tell $ buildFGBody body-                                    return body-          }+  where+    folder =+      identityMapper+        { mapOnBody = \_ body -> do+            tell $ buildFGBody body+            return body+        }  -- | The set of all functions that are called noinline somewhere, or -- have a noinline attribute on their definition. findNoninlined :: Prog SOACS -> S.Set Name findNoninlined prog =-  foldMap noinlineDef (progFuns prog) <>-  foldMap onStm (foldMap (bodyStms . funDefBody) (progFuns prog) <> progConsts prog)-  where onStm :: Stm -> S.Set Name-        onStm (Let _ aux (Apply fname _ _ _))-          | "noinline" `inAttrs` stmAuxAttrs aux =-              S.singleton fname-        onStm (Let _ _ e) = execWriter $ mapExpM folder e-          where folder =-                  identityMapper-                  { mapOnBody = \_ body -> do tell $ foldMap onStm $ bodyStms body-                                              return body-                  , mapOnOp = mapSOACM-                              identitySOACMapper-                              { mapOnSOACLambda = \lam -> do-                                  tell $ foldMap onStm $ bodyStms $ lambdaBody lam-                                  return lam-                              }-                  }+  foldMap noinlineDef (progFuns prog)+    <> foldMap onStm (foldMap (bodyStms . funDefBody) (progFuns prog) <> progConsts prog)+  where+    onStm :: Stm -> S.Set Name+    onStm (Let _ aux (Apply fname _ _ _))+      | "noinline" `inAttrs` stmAuxAttrs aux =+        S.singleton fname+    onStm (Let _ _ e) = execWriter $ mapExpM folder e+      where+        folder =+          identityMapper+            { mapOnBody = \_ body -> do+                tell $ foldMap onStm $ bodyStms body+                return body,+              mapOnOp =+                mapSOACM+                  identitySOACMapper+                    { mapOnSOACLambda = \lam -> do+                        tell $ foldMap onStm $ bodyStms $ lambdaBody lam+                        return lam+                    }+            } -        noinlineDef fd-          | "noinline" `inAttrs` funDefAttrs fd =-              S.singleton $ funDefName fd-          | otherwise =-              mempty+    noinlineDef fd+      | "noinline" `inAttrs` funDefAttrs fd =+        S.singleton $ funDefName fd+      | otherwise =+        mempty

@@ -1,14 +1,14 @@ {-# LANGUAGE FlexibleContexts #-}+ -- | Facilities for inspecting the data dependencies of a program. module Futhark.Analysis.DataDependencies-  ( Dependencies-  , dataDependencies-  , findNecessaryForReturned+  ( Dependencies,+    dataDependencies,+    findNecessaryForReturned,   )-  where+where  import qualified Data.Map.Strict as M- import Futhark.IR  -- | A mapping from a variable name @v@, to those variables on which@@ -21,31 +21,39 @@ dataDependencies :: ASTLore lore => Body lore -> Dependencies dataDependencies = dataDependencies' M.empty -dataDependencies' :: ASTLore lore =>-                     Dependencies -> Body lore -> Dependencies+dataDependencies' ::+  ASTLore lore =>+  Dependencies ->+  Body lore ->+  Dependencies dataDependencies' startdeps = foldl grow startdeps . bodyStms-  where grow deps (Let pat _ (If c tb fb _)) =-          let tdeps = dataDependencies' deps tb-              fdeps = dataDependencies' deps fb-              cdeps = depsOf deps c-              comb (pe, tres, fres) =-                (patElemName pe,-                 mconcat $ [freeIn pe, cdeps, depsOf tdeps tres, depsOf fdeps fres] ++-                 map (depsOfVar deps) (namesToList $ freeIn pe))-              branchdeps =-                M.fromList $ map comb $ zip3 (patternElements pat)-                (bodyResult tb)-                (bodyResult fb)-          in M.unions [branchdeps, deps, tdeps, fdeps]--        grow deps (Let pat _ e) =-          let free = freeIn pat <> freeIn e-              freeDeps = mconcat $ map (depsOfVar deps) $ namesToList free-          in M.fromList [ (name, freeDeps) | name <- patternNames pat ] `M.union` deps+  where+    grow deps (Let pat _ (If c tb fb _)) =+      let tdeps = dataDependencies' deps tb+          fdeps = dataDependencies' deps fb+          cdeps = depsOf deps c+          comb (pe, tres, fres) =+            ( patElemName pe,+              mconcat $+                [freeIn pe, cdeps, depsOf tdeps tres, depsOf fdeps fres]+                  ++ map (depsOfVar deps) (namesToList $ freeIn pe)+            )+          branchdeps =+            M.fromList $+              map comb $+                zip3+                  (patternElements pat)+                  (bodyResult tb)+                  (bodyResult fb)+       in M.unions [branchdeps, deps, tdeps, fdeps]+    grow deps (Let pat _ e) =+      let free = freeIn pat <> freeIn e+          freeDeps = mconcat $ map (depsOfVar deps) $ namesToList free+       in M.fromList [(name, freeDeps) | name <- patternNames pat] `M.union` deps  depsOf :: Dependencies -> SubExp -> Names depsOf _ (Constant _) = mempty-depsOf deps (Var v)   = depsOfVar deps v+depsOf deps (Var v) = depsOfVar deps v  depsOfVar :: Dependencies -> VName -> Names depsOfVar deps name = oneName name <> M.findWithDefault mempty name deps@@ -56,21 +64,25 @@ -- of that parameter is live after the loop.  @deps@ is the data -- dependencies of the loop body.  This is computed by straightforward -- fixpoint iteration.-findNecessaryForReturned :: (Param dec -> Bool) -> [(Param dec, SubExp)]-                         -> M.Map VName Names-                         -> Names+findNecessaryForReturned ::+  (Param dec -> Bool) ->+  [(Param dec, SubExp)] ->+  M.Map VName Names ->+  Names findNecessaryForReturned usedAfterLoop merge_and_res allDependencies =-  iterateNecessary mempty <>-  namesFromList (map paramName $ filter usedAfterLoop $ map fst merge_and_res)-  where iterateNecessary prev_necessary-          | necessary == prev_necessary = necessary-          | otherwise                   = iterateNecessary necessary-          where necessary = mconcat $ map dependencies returnedResultSubExps-                usedAfterLoopOrNecessary param =-                  usedAfterLoop param || paramName param `nameIn` prev_necessary-                returnedResultSubExps =-                  map snd $ filter (usedAfterLoopOrNecessary . fst) merge_and_res-                dependencies (Constant _) =-                  mempty-                dependencies (Var v)      =-                  M.findWithDefault (oneName v) v allDependencies+  iterateNecessary mempty+    <> namesFromList (map paramName $ filter usedAfterLoop $ map fst merge_and_res)+  where+    iterateNecessary prev_necessary+      | necessary == prev_necessary = necessary+      | otherwise = iterateNecessary necessary+      where+        necessary = mconcat $ map dependencies returnedResultSubExps+        usedAfterLoopOrNecessary param =+          usedAfterLoop param || paramName param `nameIn` prev_necessary+        returnedResultSubExps =+          map snd $ filter (usedAfterLoopOrNecessary . fst) merge_and_res+        dependencies (Constant _) =+          mempty+        dependencies (Var v) =+          M.findWithDefault (oneName v) v allDependencies

@@ -1,50 +1,50 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+ module Futhark.Analysis.HORep.MapNest-  ( Nesting (..)-  , MapNest (..)-  , typeOf-  , params-  , inputs-  , setInputs-  , fromSOAC-  , toSOAC+  ( Nesting (..),+    MapNest (..),+    typeOf,+    params,+    inputs,+    setInputs,+    fromSOAC,+    toSOAC,   ) where  import Data.List (find)-import Data.Maybe import qualified Data.Map.Strict as M--import qualified Futhark.Analysis.HORep.SOAC as SOAC+import Data.Maybe import Futhark.Analysis.HORep.SOAC (SOAC)+import qualified Futhark.Analysis.HORep.SOAC as SOAC+import Futhark.Construct+import Futhark.IR hiding (typeOf) import qualified Futhark.IR.SOACS.SOAC as Futhark import Futhark.Transform.Substitute-import Futhark.IR hiding (typeOf)-import Futhark.MonadFreshNames-import Futhark.Construct -data Nesting lore = Nesting {-    nestingParamNames   :: [VName]-  , nestingResult       :: [VName]-  , nestingReturnType   :: [Type]-  , nestingWidth        :: SubExp-  } deriving (Eq, Ord, Show)+data Nesting lore = Nesting+  { nestingParamNames :: [VName],+    nestingResult :: [VName],+    nestingReturnType :: [Type],+    nestingWidth :: SubExp+  }+  deriving (Eq, Ord, Show)  data MapNest lore = MapNest SubExp (Lambda lore) [Nesting lore] [SOAC.Input]-                  deriving (Show)+  deriving (Show)  typeOf :: MapNest lore -> [Type] typeOf (MapNest w lam [] _) =   map (`arrayOfRow` w) $ lambdaReturnType lam-typeOf (MapNest w _ (nest:_) _) =+typeOf (MapNest w _ (nest : _) _) =   map (`arrayOfRow` w) $ nestingReturnType nest  params :: MapNest lore -> [VName]-params (MapNest _ lam [] _)       =+params (MapNest _ lam [] _) =   map paramName $ lambdaParams lam-params (MapNest _ _ (nest:_) _) =+params (MapNest _ _ (nest : _) _) =   nestingParamNames nest  inputs :: MapNest lore -> [SOAC.Input]@@ -52,32 +52,41 @@  setInputs :: [SOAC.Input] -> MapNest lore -> MapNest lore setInputs [] (MapNest w body ns _) = MapNest w body ns []-setInputs (inp:inps) (MapNest _ body ns _) = MapNest w body ns' (inp:inps)-  where w = arraySize 0 $ SOAC.inputType inp-        ws = drop 1 $ arrayDims $ SOAC.inputType inp-        ns' = zipWith setDepth ns ws-        setDepth n nw = n { nestingWidth = nw }+setInputs (inp : inps) (MapNest _ body ns _) = MapNest w body ns' (inp : inps)+  where+    w = arraySize 0 $ SOAC.inputType inp+    ws = drop 1 $ arrayDims $ SOAC.inputType inp+    ns' = zipWith setDepth ns ws+    setDepth n nw = n {nestingWidth = nw} -fromSOAC :: (Bindable lore, MonadFreshNames m,-             LocalScope lore m,-             Op lore ~ Futhark.SOAC lore) =>-            SOAC lore -> m (Maybe (MapNest lore))+fromSOAC ::+  ( Bindable lore,+    MonadFreshNames m,+    LocalScope lore m,+    Op lore ~ Futhark.SOAC lore+  ) =>+  SOAC lore ->+  m (Maybe (MapNest lore)) fromSOAC = fromSOAC' mempty -fromSOAC' :: (Bindable lore, MonadFreshNames m,-              LocalScope lore m,-              Op lore ~ Futhark.SOAC lore) =>-             [Ident]-          -> SOAC lore-          -> m (Maybe (MapNest lore))-+fromSOAC' ::+  ( Bindable lore,+    MonadFreshNames m,+    LocalScope lore m,+    Op lore ~ Futhark.SOAC lore+  ) =>+  [Ident] ->+  SOAC lore ->+  m (Maybe (MapNest lore)) fromSOAC' bound (SOAC.Screma w (SOAC.ScremaForm [] [] lam) inps) = do-  maybenest <- case (stmsToList $ bodyStms $ lambdaBody lam,-                     bodyResult $ lambdaBody lam) of-    ([Let pat _ e], res) | res == map Var (patternNames pat) ->-      localScope (scopeOfLParams $ lambdaParams lam) $-      SOAC.fromExp e >>=-      either (return . Left) (fmap (Right . fmap (pat,)) . fromSOAC' bound')+  maybenest <- case ( stmsToList $ bodyStms $ lambdaBody lam,+                      bodyResult $ lambdaBody lam+                    ) of+    ([Let pat _ e], res)+      | res == map Var (patternNames pat) ->+        localScope (scopeOfLParams $ lambdaParams lam) $+          SOAC.fromExp e+            >>= either (return . Left) (fmap (Right . fmap (pat,)) . fromSOAC' bound')     _ ->       return $ Right Nothing @@ -85,72 +94,93 @@     -- Do we have a nested MapNest?     Right (Just (pat, mn@(MapNest inner_w body' ns' inps'))) -> do       (ps, inps'') <--        unzip <$>-        fixInputs w (zip (map paramName $ lambdaParams lam) inps)-        (zip (params mn) inps')-      let n' = Nesting { nestingParamNames = ps-                       , nestingResult     = patternNames pat-                       , nestingReturnType = typeOf mn-                       , nestingWidth      = inner_w-                       }-      return $ Just $ MapNest w body' (n':ns') inps''+        unzip+          <$> fixInputs+            w+            (zip (map paramName $ lambdaParams lam) inps)+            (zip (params mn) inps')+      let n' =+            Nesting+              { nestingParamNames = ps,+                nestingResult = patternNames pat,+                nestingReturnType = typeOf mn,+                nestingWidth = inner_w+              }+      return $ Just $ MapNest w body' (n' : ns') inps''     -- No nested MapNest it seems.     _ -> do       let isBound name-            | Just param <- find ((name==) . identName) bound =+            | Just param <- find ((name ==) . identName) bound =               Just param             | otherwise =               Nothing           boundUsedInBody =             mapMaybe isBound $ namesToList $ freeIn lam-      newParams <- mapM (newIdent' (++"_wasfree")) boundUsedInBody-      let subst = M.fromList $-                  zip (map identName boundUsedInBody) (map identName newParams)-          inps' = inps ++-                  map (SOAC.addTransform (SOAC.Replicate mempty $ Shape [w]) . SOAC.identInput)-                  boundUsedInBody+      newParams <- mapM (newIdent' (++ "_wasfree")) boundUsedInBody+      let subst =+            M.fromList $+              zip (map identName boundUsedInBody) (map identName newParams)+          inps' =+            inps+              ++ map+                (SOAC.addTransform (SOAC.Replicate mempty $ Shape [w]) . SOAC.identInput)+                boundUsedInBody           lam' =-            lam { lambdaBody =-                    substituteNames subst $ lambdaBody lam-                , lambdaParams =-                    lambdaParams lam ++ [ Param name t-                                        | Ident name t <- newParams ]-                }+            lam+              { lambdaBody =+                  substituteNames subst $ lambdaBody lam,+                lambdaParams =+                  lambdaParams lam+                    ++ [ Param name t+                         | Ident name t <- newParams+                       ]+              }       return $ Just $ MapNest w lam' [] inps'-  where bound' = bound <> map paramIdent (lambdaParams lam)-+  where+    bound' = bound <> map paramIdent (lambdaParams lam) fromSOAC' _ _ = return Nothing -toSOAC :: (MonadFreshNames m, HasScope lore m,-           Bindable lore, BinderOps lore, Op lore ~ Futhark.SOAC lore) =>-          MapNest lore -> m (SOAC lore)+toSOAC ::+  ( MonadFreshNames m,+    HasScope lore m,+    Bindable lore,+    BinderOps lore,+    Op lore ~ Futhark.SOAC lore+  ) =>+  MapNest lore ->+  m (SOAC lore) toSOAC (MapNest w lam [] inps) =   return $ SOAC.Screma w (Futhark.mapSOAC lam) inps-toSOAC (MapNest w lam (Nesting npnames nres nrettype nw:ns) inps) = do+toSOAC (MapNest w lam (Nesting npnames nres nrettype nw : ns) inps) = do   let nparams = zipWith Param npnames $ map SOAC.inputRowType inps-  body <- runBodyBinder $ localScope (scopeOfLParams nparams) $ do-    letBindNames nres =<< SOAC.toExp =<<-      toSOAC (MapNest nw lam ns $ map (SOAC.identInput . paramIdent) nparams)-    return $ resultBody $ map Var nres-  let outerlam = Lambda { lambdaParams = nparams-                        , lambdaBody = body-                        , lambdaReturnType = nrettype-                        }+  body <- runBodyBinder $+    localScope (scopeOfLParams nparams) $ do+      letBindNames nres =<< SOAC.toExp+        =<< toSOAC (MapNest nw lam ns $ map (SOAC.identInput . paramIdent) nparams)+      return $ resultBody $ map Var nres+  let outerlam =+        Lambda+          { lambdaParams = nparams,+            lambdaBody = body,+            lambdaReturnType = nrettype+          }   return $ SOAC.Screma w (Futhark.mapSOAC outerlam) inps -fixInputs :: MonadFreshNames m =>-             SubExp -> [(VName, SOAC.Input)] -> [(VName, SOAC.Input)]-          -> m [(VName, SOAC.Input)]+fixInputs ::+  MonadFreshNames m =>+  SubExp ->+  [(VName, SOAC.Input)] ->+  [(VName, SOAC.Input)] ->+  m [(VName, SOAC.Input)] fixInputs w ourInps = mapM inspect   where     isParam x (y, _) = x == y      inspect (_, SOAC.Input ts v _)-      | Just (p,pInp) <- find (isParam v) ourInps = do-          let pInp' = SOAC.transformRows ts pInp-          p' <- newNameFromString $ baseString p-          return (p', pInp')-+      | Just (p, pInp) <- find (isParam v) ourInps = do+        let pInp' = SOAC.transformRows ts pInp+        p' <- newNameFromString $ baseString p+        return (p', pInp')     inspect (param, SOAC.Input ts a t) = do       param' <- newNameFromString (baseString param ++ "_rep")       return (param', SOAC.Input (ts SOAC.|> SOAC.Replicate mempty (Shape [w])) a t)

@@ -1,5 +1,6 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+ -- | High-level representation of SOACs.  When performing -- SOAC-transformations, operating on normal 'Exp' values is somewhat -- of a nuisance, as they can represent terms that are not proper@@ -21,80 +22,94 @@ -- import qualified Futhark.Analysis.HORep.SOAC as SOAC -- @ module Futhark.Analysis.HORep.SOAC-  (-   -- * SOACs-    SOAC (..)-  , Futhark.ScremaForm(..)-  , inputs-  , setInputs-  , lambda-  , setLambda-  , typeOf-  , width-  -- ** Converting to and from expressions-  , NotSOAC (..)-  , fromExp-  , toExp-  , toSOAC-  -- * SOAC inputs-  , Input (..)-  , varInput-  , identInput-  , isVarInput-  , isVarishInput-  , addTransform-  , addInitialTransforms-  , inputArray-  , inputRank-  , inputType-  , inputRowType-  , transformRows-  , transposeInput-  -- ** Input transformations-  , ArrayTransforms-  , noTransforms-  , nullTransforms-  , (|>)-  , (<|)-  , viewf-  , ViewF(..)-  , viewl-  , ViewL(..)-  , ArrayTransform(..)-  , transformFromExp-  , soacToStream+  ( -- * SOACs+    SOAC (..),+    Futhark.ScremaForm (..),+    inputs,+    setInputs,+    lambda,+    setLambda,+    typeOf,+    width,++    -- ** Converting to and from expressions+    NotSOAC (..),+    fromExp,+    toExp,+    toSOAC,++    -- * SOAC inputs+    Input (..),+    varInput,+    identInput,+    isVarInput,+    isVarishInput,+    addTransform,+    addInitialTransforms,+    inputArray,+    inputRank,+    inputType,+    inputRowType,+    transformRows,+    transposeInput,++    -- ** Input transformations+    ArrayTransforms,+    noTransforms,+    nullTransforms,+    (|>),+    (<|),+    viewf,+    ViewF (..),+    viewl,+    ViewL (..),+    ArrayTransform (..),+    transformFromExp,+    soacToStream,   )-  where+where  import Data.Foldable as Foldable import Data.Maybe import qualified Data.Sequence as Seq-+import Futhark.Construct hiding (toExp)+import Futhark.IR hiding+  ( Iota,+    Rearrange,+    Replicate,+    Reshape,+    Var,+    typeOf,+  ) import qualified Futhark.IR as Futhark import Futhark.IR.SOACS.SOAC-  (StreamForm(..), ScremaForm(..), scremaType, getStreamAccums, HistOp(..), StreamOrd(..))+  ( HistOp (..),+    ScremaForm (..),+    StreamForm (..),+    StreamOrd (..),+    getStreamAccums,+    scremaType,+  ) import qualified Futhark.IR.SOACS.SOAC as Futhark-import Futhark.IR-  hiding (Var, Iota, Rearrange, Reshape, Replicate, typeOf)-import Futhark.Transform.Substitute-import Futhark.Construct hiding (toExp) import Futhark.Transform.Rename (renameLambda)-import qualified Futhark.Util.Pretty as PP+import Futhark.Transform.Substitute import Futhark.Util.Pretty (ppr, text)+import qualified Futhark.Util.Pretty as PP  -- | A single, simple transformation.  If you want several, don't just -- create a list, use 'ArrayTransforms' instead.-data ArrayTransform = Rearrange Certificates [Int]-                    -- ^ A permutation of an otherwise valid input.-                    | Reshape Certificates (ShapeChange SubExp)-                    -- ^ A reshaping of an otherwise valid input.-                    | ReshapeOuter Certificates (ShapeChange SubExp)-                    -- ^ A reshaping of the outer dimension.-                    | ReshapeInner Certificates (ShapeChange SubExp)-                    -- ^ A reshaping of everything but the outer dimension.-                    | Replicate Certificates Shape-                    -- ^ Replicate the rows of the array a number of times.-                      deriving (Show, Eq, Ord)+data ArrayTransform+  = -- | A permutation of an otherwise valid input.+    Rearrange Certificates [Int]+  | -- | A reshaping of an otherwise valid input.+    Reshape Certificates (ShapeChange SubExp)+  | -- | A reshaping of the outer dimension.+    ReshapeOuter Certificates (ShapeChange SubExp)+  | -- | A reshaping of everything but the outer dimension.+    ReshapeInner Certificates (ShapeChange SubExp)+  | -- | Replicate the rows of the array a number of times.+    Replicate Certificates Shape+  deriving (Show, Eq, Ord)  instance Substitute ArrayTransform where   substituteNames substs (Rearrange cs xs) =@@ -124,8 +139,8 @@  instance Semigroup ArrayTransforms where   ts1 <> ts2 = case viewf ts2 of-                 t :< ts2' -> (ts1 |> t) <> ts2'-                 EmptyF    -> ts1+    t :< ts2' -> (ts1 |> t) <> ts2'+    EmptyF -> ts1  instance Monoid ArrayTransforms where   mempty = noTransforms@@ -145,59 +160,67 @@ -- | Decompose the input-end of the transformation sequence. viewf :: ArrayTransforms -> ViewF viewf (ArrayTransforms s) = case Seq.viewl s of-                              t Seq.:< s' -> t :< ArrayTransforms s'-                              Seq.EmptyL  -> EmptyF+  t Seq.:< s' -> t :< ArrayTransforms s'+  Seq.EmptyL -> EmptyF  -- | A view of the first transformation to be applied.-data ViewF = EmptyF-           | ArrayTransform :< ArrayTransforms+data ViewF+  = EmptyF+  | ArrayTransform :< ArrayTransforms  -- | Decompose the output-end of the transformation sequence. viewl :: ArrayTransforms -> ViewL viewl (ArrayTransforms s) = case Seq.viewr s of-                              s' Seq.:> t -> ArrayTransforms s' :> t-                              Seq.EmptyR  -> EmptyL+  s' Seq.:> t -> ArrayTransforms s' :> t+  Seq.EmptyR -> EmptyL  -- | A view of the last transformation to be applied.-data ViewL = EmptyL-           | ArrayTransforms :> ArrayTransform+data ViewL+  = EmptyL+  | ArrayTransforms :> ArrayTransform  -- | Add a transform to the end of the transformation list. (|>) :: ArrayTransforms -> ArrayTransform -> ArrayTransforms (|>) = flip $ addTransform' extract add $ uncurry (flip (,))-   where extract ts' = case viewl ts' of-                         EmptyL     -> Nothing-                         ts'' :> t' -> Just (t', ts'')-         add t' (ArrayTransforms ts') = ArrayTransforms $ ts' Seq.|> t'+  where+    extract ts' = case viewl ts' of+      EmptyL -> Nothing+      ts'' :> t' -> Just (t', ts'')+    add t' (ArrayTransforms ts') = ArrayTransforms $ ts' Seq.|> t'  -- | Add a transform at the beginning of the transformation list. (<|) :: ArrayTransform -> ArrayTransforms -> ArrayTransforms (<|) = addTransform' extract add id-   where extract ts' = case viewf ts' of-                         EmptyF     -> Nothing-                         t' :< ts'' -> Just (t', ts'')-         add t' (ArrayTransforms ts') = ArrayTransforms $ t' Seq.<| ts'+  where+    extract ts' = case viewf ts' of+      EmptyF -> Nothing+      t' :< ts'' -> Just (t', ts'')+    add t' (ArrayTransforms ts') = ArrayTransforms $ t' Seq.<| ts' -addTransform' :: (ArrayTransforms -> Maybe (ArrayTransform, ArrayTransforms))-              -> (ArrayTransform -> ArrayTransforms -> ArrayTransforms)-              -> ((ArrayTransform,ArrayTransform) -> (ArrayTransform,ArrayTransform))-              -> ArrayTransform -> ArrayTransforms-              -> ArrayTransforms+addTransform' ::+  (ArrayTransforms -> Maybe (ArrayTransform, ArrayTransforms)) ->+  (ArrayTransform -> ArrayTransforms -> ArrayTransforms) ->+  ((ArrayTransform, ArrayTransform) -> (ArrayTransform, ArrayTransform)) ->+  ArrayTransform ->+  ArrayTransforms ->+  ArrayTransforms addTransform' extract add swap t ts =   fromMaybe (t `add` ts) $ do     (t', ts') <- extract ts     combined <- uncurry combineTransforms $ swap (t', t)-    Just $ if identityTransform combined then ts'-           else addTransform' extract add swap combined ts'+    Just $+      if identityTransform combined+        then ts'+        else addTransform' extract add swap combined ts'  identityTransform :: ArrayTransform -> Bool identityTransform (Rearrange _ perm) =-  Foldable.and $ zipWith (==) perm [0..]+  Foldable.and $ zipWith (==) perm [0 ..] identityTransform _ = False  combineTransforms :: ArrayTransform -> ArrayTransform -> Maybe ArrayTransform combineTransforms (Rearrange cs2 perm2) (Rearrange cs1 perm1) =-  Just $ Rearrange (cs1<>cs2) $ perm2 `rearrangeCompose` perm1+  Just $ Rearrange (cs1 <> cs2) $ perm2 `rearrangeCompose` perm1 combineTransforms _ _ = Nothing  -- | Given an expression, determine whether the expression represents@@ -219,17 +242,20 @@ -- plain expressions.  The transforms are done left-to-right, that is, -- the first element of the 'ArrayTransform' list is applied first. data Input = Input ArrayTransforms VName Type-             deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord)  instance Substitute Input where   substituteNames substs (Input ts v t) =-    Input (substituteNames substs ts)-    (substituteNames substs v) (substituteNames substs t)+    Input+      (substituteNames substs ts)+      (substituteNames substs v)+      (substituteNames substs t)  -- | Create a plain array variable input with no transformations. varInput :: HasScope t f => VName -> f Input varInput v = withType <$> lookupType v-  where withType = Input (ArrayTransforms Seq.empty) v+  where+    withType = Input (ArrayTransforms Seq.empty) v  -- | Create a plain array variable input with no transformations, from an 'Ident'. identInput :: Ident -> Input@@ -239,15 +265,16 @@ -- return the variable. isVarInput :: Input -> Maybe VName isVarInput (Input ts v _) | nullTransforms ts = Just v-isVarInput _                                  = Nothing+isVarInput _ = Nothing  -- | If the given input is a plain variable input, with no non-vacuous transforms, -- return the variable. isVarishInput :: Input -> Maybe VName isVarishInput (Input ts v t)   | nullTransforms ts = Just v-  | Reshape cs [DimCoercion _] :< ts' <- viewf ts, cs == mempty =-      isVarishInput $ Input ts' v t+  | Reshape cs [DimCoercion _] :< ts' <- viewf ts,+    cs == mempty =+    isVarishInput $ Input ts' v t isVarishInput _ = Nothing  -- | Add a transformation to the end of the transformation list.@@ -261,33 +288,32 @@ addInitialTransforms ts (Input ots a t) = Input (ts <> ots) a t  -- | Convert SOAC inputs to the corresponding expressions.-inputsToSubExps :: (MonadBinder m) =>-                   [Input] -> m [VName]+inputsToSubExps ::+  (MonadBinder m) =>+  [Input] ->+  m [VName] inputsToSubExps = mapM inputToExp'-  where inputToExp' (Input (ArrayTransforms ts) a _) =-          foldlM transform a ts--        transform ia (Replicate cs n) =-          certifying cs $-          letExp "repeat" $ BasicOp $ Futhark.Replicate n (Futhark.Var ia)--        transform ia (Rearrange cs perm) =-          certifying cs $-          letExp "rearrange" $ BasicOp $ Futhark.Rearrange perm ia--        transform ia (Reshape cs shape) =-          certifying cs $-          letExp "reshape" $ BasicOp $ Futhark.Reshape shape ia--        transform ia (ReshapeOuter cs shape) = do-          shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia-          certifying cs $-            letExp "reshape_outer" $ BasicOp $ Futhark.Reshape shape' ia+  where+    inputToExp' (Input (ArrayTransforms ts) a _) =+      foldlM transform a ts -        transform ia (ReshapeInner cs shape) = do-          shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia-          certifying cs $-            letExp "reshape_inner" $ BasicOp $ Futhark.Reshape shape' ia+    transform ia (Replicate cs n) =+      certifying cs $+        letExp "repeat" $ BasicOp $ Futhark.Replicate n (Futhark.Var ia)+    transform ia (Rearrange cs perm) =+      certifying cs $+        letExp "rearrange" $ BasicOp $ Futhark.Rearrange perm ia+    transform ia (Reshape cs shape) =+      certifying cs $+        letExp "reshape" $ BasicOp $ Futhark.Reshape shape ia+    transform ia (ReshapeOuter cs shape) = do+      shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia+      certifying cs $+        letExp "reshape_outer" $ BasicOp $ Futhark.Reshape shape' ia+    transform ia (ReshapeInner cs shape) = do+      shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia+      certifying cs $+        letExp "reshape_inner" $ BasicOp $ Futhark.Reshape shape' ia  -- | Return the array name of the input. inputArray :: Input -> VName@@ -297,18 +323,19 @@ inputType :: Input -> Type inputType (Input (ArrayTransforms ts) _ at) =   Foldable.foldl transformType at ts-  where transformType t (Replicate _ shape) =-          arrayOfShape t shape-        transformType t (Rearrange _ perm) =-          rearrangeType perm t-        transformType t (Reshape _ shape) =-          t `setArrayShape` newShape shape-        transformType t (ReshapeOuter _ shape) =-          let Shape oldshape = arrayShape t-          in t `setArrayShape` Shape (newDims shape ++ drop 1 oldshape)-        transformType t (ReshapeInner _ shape) =-          let Shape oldshape = arrayShape t-          in t `setArrayShape` Shape (take 1 oldshape ++ newDims shape)+  where+    transformType t (Replicate _ shape) =+      arrayOfShape t shape+    transformType t (Rearrange _ perm) =+      rearrangeType perm t+    transformType t (Reshape _ shape) =+      t `setArrayShape` newShape shape+    transformType t (ReshapeOuter _ shape) =+      let Shape oldshape = arrayShape t+       in t `setArrayShape` Shape (newDims shape ++ drop 1 oldshape)+    transformType t (ReshapeInner _ shape) =+      let Shape oldshape = arrayShape t+       in t `setArrayShape` Shape (take 1 oldshape ++ newDims shape)  -- | Return the row type of an input.  Just a convenient alias. inputRowType :: Input -> Type@@ -323,47 +350,51 @@ transformRows :: ArrayTransforms -> Input -> Input transformRows (ArrayTransforms ts) =   flip (Foldable.foldl transformRows') ts-  where transformRows' inp (Rearrange cs perm) =-          addTransform (Rearrange cs (0:map (+1) perm)) inp-        transformRows' inp (Reshape cs shape) =-          addTransform (ReshapeInner cs shape) inp-        transformRows' inp (Replicate cs n)-          | inputRank inp == 1 =-            Rearrange mempty [1,0] `addTransform`-            (Replicate cs n `addTransform` inp)-          | otherwise =-            Rearrange mempty (2:0:1:[3..inputRank inp]) `addTransform`-            (Replicate cs n `addTransform`-             (Rearrange mempty (1:0:[2..inputRank inp-1]) `addTransform` inp))-        transformRows' inp nts =-          error $ "transformRows: Cannot transform this yet:\n" ++ show nts ++ "\n" ++ show inp+  where+    transformRows' inp (Rearrange cs perm) =+      addTransform (Rearrange cs (0 : map (+ 1) perm)) inp+    transformRows' inp (Reshape cs shape) =+      addTransform (ReshapeInner cs shape) inp+    transformRows' inp (Replicate cs n)+      | inputRank inp == 1 =+        Rearrange mempty [1, 0]+          `addTransform` (Replicate cs n `addTransform` inp)+      | otherwise =+        Rearrange mempty (2 : 0 : 1 : [3 .. inputRank inp])+          `addTransform` ( Replicate cs n+                             `addTransform` (Rearrange mempty (1 : 0 : [2 .. inputRank inp -1]) `addTransform` inp)+                         )+    transformRows' inp nts =+      error $ "transformRows: Cannot transform this yet:\n" ++ show nts ++ "\n" ++ show inp  -- | Add to the input a 'Rearrange' transform that performs an @(k,n)@ -- transposition.  The new transform will be at the end of the current -- transformation list. transposeInput :: Int -> Int -> Input -> Input transposeInput k n inp =-  addTransform (Rearrange mempty $ transposeIndex k n [0..inputRank inp-1]) inp+  addTransform (Rearrange mempty $ transposeIndex k n [0 .. inputRank inp -1]) inp  -- | A definite representation of a SOAC expression.-data SOAC lore = Stream SubExp (StreamForm lore) (Lambda lore) [Input]-               | Scatter SubExp (Lambda lore) [Input] [(SubExp, Int, VName)]-               | Screma SubExp (ScremaForm lore) [Input]-               | Hist SubExp [HistOp lore] (Lambda lore) [Input]-            deriving (Eq, Show)+data SOAC lore+  = Stream SubExp (StreamForm lore) (Lambda lore) [Input]+  | Scatter SubExp (Lambda lore) [Input] [(SubExp, Int, VName)]+  | Screma SubExp (ScremaForm lore) [Input]+  | Hist SubExp [HistOp lore] (Lambda lore) [Input]+  deriving (Eq, Show)  instance PP.Pretty Input where   ppr (Input (ArrayTransforms ts) arr _) = foldl f (ppr arr) ts-    where f e (Rearrange cs perm) =-            text "rearrange" <> ppr cs <> PP.apply [PP.apply (map ppr perm), e]-          f e (Reshape cs shape) =-            text "reshape" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e]-          f e (ReshapeOuter cs shape) =-            text "reshape_outer" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e]-          f e (ReshapeInner cs shape) =-            text "reshape_inner" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e]-          f e (Replicate cs ne) =-            text "replicate" <> ppr cs <> PP.apply [ppr ne, e]+    where+      f e (Rearrange cs perm) =+        text "rearrange" <> ppr cs <> PP.apply [PP.apply (map ppr perm), e]+      f e (Reshape cs shape) =+        text "reshape" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e]+      f e (ReshapeOuter cs shape) =+        text "reshape_outer" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e]+      f e (ReshapeInner cs shape) =+        text "reshape_inner" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e]+      f e (Replicate cs ne) =+        text "replicate" <> ppr cs <> PP.apply [ppr ne, e]  instance PrettyLore lore => PP.Pretty (SOAC lore) where   ppr (Screma w form arrs) = Futhark.ppScrema w form arrs@@ -373,9 +404,9 @@  -- | Returns the inputs used in a SOAC. inputs :: SOAC lore -> [Input]-inputs (Stream   _ _ _     arrs) = arrs-inputs (Scatter  _len _lam ivs _as) = ivs-inputs (Screma _ _       arrs) = arrs+inputs (Stream _ _ _ arrs) = arrs+inputs (Scatter _len _lam ivs _as) = ivs+inputs (Screma _ _ arrs) = arrs inputs (Hist _ _ _ inps) = inps  -- | Set the inputs to a SOAC.@@ -391,11 +422,11 @@  newWidth :: [Input] -> SubExp -> SubExp newWidth [] w = w-newWidth (inp:_) _ = arraySize 0 $ inputType inp+newWidth (inp : _) _ = arraySize 0 $ inputType inp  -- | The lambda used in a given SOAC. lambda :: SOAC lore -> Lambda lore-lambda (Stream  _ _ lam      _) = lam+lambda (Stream _ _ lam _) = lam lambda (Scatter _len lam _ivs _as) = lam lambda (Screma _ (ScremaForm _ _ lam) _) = lam lambda (Hist _ _ lam _) = lam@@ -414,16 +445,19 @@ -- | The return type of a SOAC. typeOf :: SOAC lore -> [Type] typeOf (Stream w form lam _) =-  let nes     = getStreamAccums form+  let nes = getStreamAccums form       accrtps = take (length nes) $ lambdaReturnType lam-      arrtps  = [ arrayOf (stripArray 1 t) (Shape [w]) NoUniqueness-                  | t <- drop (length nes) (lambdaReturnType lam) ]-  in  accrtps ++ arrtps+      arrtps =+        [ arrayOf (stripArray 1 t) (Shape [w]) NoUniqueness+          | t <- drop (length nes) (lambdaReturnType lam)+        ]+   in accrtps ++ arrtps typeOf (Scatter _w lam _ivs dests) =   zipWith arrayOfRow (drop (n `div` 2) lam_ts) aws-  where lam_ts = lambdaReturnType lam-        n = length lam_ts-        (aws, _, _) = unzip3 dests+  where+    lam_ts = lambdaReturnType lam+    n = length lam_ts+    (aws, _, _) = unzip3 dests typeOf (Screma w form _) =   scremaType w form typeOf (Hist _ ops _ _) = do@@ -439,13 +473,17 @@ width (Hist w _ _ _) = w  -- | Convert a SOAC to the corresponding expression.-toExp :: (MonadBinder m, Op (Lore m) ~ Futhark.SOAC (Lore m)) =>-         SOAC (Lore m) -> m (Exp (Lore m))+toExp ::+  (MonadBinder m, Op (Lore m) ~ Futhark.SOAC (Lore m)) =>+  SOAC (Lore m) ->+  m (Exp (Lore m)) toExp soac = Op <$> toSOAC soac  -- | Convert a SOAC to a Futhark-level SOAC.-toSOAC :: MonadBinder m =>-          SOAC (Lore m) -> m (Futhark.SOAC (Lore m))+toSOAC ::+  MonadBinder m =>+  SOAC (Lore m) ->+  m (Futhark.SOAC (Lore m)) toSOAC (Stream w form lam inps) =   Futhark.Stream w form lam <$> inputsToSubExps inps toSOAC (Scatter len lam ivs dests) = do@@ -458,14 +496,18 @@  -- | The reason why some expression cannot be converted to a 'SOAC' -- value.-data NotSOAC = NotSOAC -- ^ The expression is not a (tuple-)SOAC at all.-               deriving (Show)+data NotSOAC+  = -- | The expression is not a (tuple-)SOAC at all.+    NotSOAC+  deriving (Show)  -- | Either convert an expression to the normalised SOAC -- representation, or a reason why the expression does not have the -- valid form.-fromExp :: (Op lore ~ Futhark.SOAC lore, HasScope lore m) =>-           Exp lore -> m (Either NotSOAC (SOAC lore))+fromExp ::+  (Op lore ~ Futhark.SOAC lore, HasScope lore m) =>+  Exp lore ->+  m (Either NotSOAC (SOAC lore)) fromExp (Op (Futhark.Stream w form lam as)) =   Right . Stream w form lam <$> traverse varInput as fromExp (Op (Futhark.Scatter len lam ivs as)) =@@ -479,159 +521,213 @@ -- | To-Stream translation of SOACs. --   Returns the Stream SOAC and the --   extra-accumulator body-result ident if any.-soacToStream :: (MonadFreshNames m, Bindable lore, Op lore ~ Futhark.SOAC lore) =>-                SOAC lore -> m (SOAC lore,[Ident])+soacToStream ::+  (MonadFreshNames m, Bindable lore, Op lore ~ Futhark.SOAC lore) =>+  SOAC lore ->+  m (SOAC lore, [Ident]) soacToStream soac = do-  chunk_param <- newParam "chunk" $ Prim int32-  let chvar= Futhark.Var $ paramName chunk_param+  chunk_param <- newParam "chunk" $ Prim int64+  let chvar = Futhark.Var $ paramName chunk_param       (lam, inps) = (lambda soac, inputs soac)       w = width soac-  lam'     <- renameLambda lam-  let arrrtps= mapType w lam+  lam' <- renameLambda lam+  let arrrtps = mapType w lam       -- the chunked-outersize of the array result and input types-      loutps = [ arrayOfRow t chvar | t <- map rowType   arrrtps ]-      lintps = [ arrayOfRow t chvar | t <- map inputRowType inps ]+      loutps = [arrayOfRow t chvar | t <- map rowType arrrtps]+      lintps = [arrayOfRow t chvar | t <- map inputRowType inps]    strm_inpids <- mapM (newParam "inp") lintps   -- Treat each SOAC case individually:   case soac of     Screma _ form _       | Just _ <- Futhark.isMapSOAC form -> do-      -- Map(f,a) => is translated in strem's body to:-      -- let strm_resids = map(f,a_ch) in strm_resids-      ---      -- array result and input IDs of the stream's lambda-      strm_resids <- mapM (newIdent "res") loutps-      let insoac = Futhark.Screma chvar (Futhark.mapSOAC lam') $ map paramName strm_inpids-          insbnd = mkLet [] strm_resids $ Op insoac-          strmbdy= mkBody (oneStm insbnd) $ map (Futhark.Var . identName) strm_resids-          strmpar= chunk_param:strm_inpids-          strmlam= Lambda strmpar strmbdy loutps-          empty_lam = Lambda [] (mkBody mempty []) []-      -- map(f,a) creates a stream with NO accumulators-      return (Stream w (Parallel Disorder Commutative empty_lam []) strmlam inps, [])-+        -- Map(f,a) => is translated in strem's body to:+        -- let strm_resids = map(f,a_ch) in strm_resids+        --+        -- array result and input IDs of the stream's lambda+        strm_resids <- mapM (newIdent "res") loutps+        let insoac = Futhark.Screma chvar (Futhark.mapSOAC lam') $ map paramName strm_inpids+            insbnd = mkLet [] strm_resids $ Op insoac+            strmbdy = mkBody (oneStm insbnd) $ map (Futhark.Var . identName) strm_resids+            strmpar = chunk_param : strm_inpids+            strmlam = Lambda strmpar strmbdy loutps+            empty_lam = Lambda [] (mkBody mempty []) []+        -- map(f,a) creates a stream with NO accumulators+        return (Stream w (Parallel Disorder Commutative empty_lam []) strmlam inps, [])       | Just (scans, _) <- Futhark.isScanomapSOAC form,         Futhark.Scan scan_lam nes <- Futhark.singleScan scans -> do-      -- scanomap(scan_lam,nes,map_lam,a) => is translated in strem's body to:-      -- 1. let (scan0_ids,map_resids)   = scanomap(scan_lam, nes, map_lam, a_ch)-      -- 2. let strm_resids = map (acc `+`,nes, scan0_ids)-      -- 3. let outerszm1id = sizeof(0,strm_resids) - 1-      -- 4. let lasteel_ids = if outerszm1id < 0-      --                      then nes-      --                      else strm_resids[outerszm1id]-      -- 5. let acc'        = acc + lasteel_ids-      --    {acc', strm_resids, map_resids}-      -- the array and accumulator result types-      let scan_arr_ts = map (`arrayOfRow` chvar) $ lambdaReturnType scan_lam-          map_arr_ts = drop (length nes) loutps-          accrtps = lambdaReturnType scan_lam--      -- array result and input IDs of the stream's lambda-      strm_resids <- mapM (newIdent "res") scan_arr_ts-      scan0_ids <- mapM (newIdent "resarr0") scan_arr_ts-      map_resids <- mapM (newIdent "map_res") map_arr_ts+        -- scanomap(scan_lam,nes,map_lam,a) => is translated in strem's body to:+        -- 1. let (scan0_ids,map_resids)   = scanomap(scan_lam, nes, map_lam, a_ch)+        -- 2. let strm_resids = map (acc `+`,nes, scan0_ids)+        -- 3. let outerszm1id = sizeof(0,strm_resids) - 1+        -- 4. let lasteel_ids = if outerszm1id < 0+        --                      then nes+        --                      else strm_resids[outerszm1id]+        -- 5. let acc'        = acc + lasteel_ids+        --    {acc', strm_resids, map_resids}+        -- the array and accumulator result types+        let scan_arr_ts = map (`arrayOfRow` chvar) $ lambdaReturnType scan_lam+            map_arr_ts = drop (length nes) loutps+            accrtps = lambdaReturnType scan_lam -      lastel_ids <- mapM (newIdent "lstel") accrtps-      lastel_tmp_ids <- mapM (newIdent "lstel_tmp") accrtps-      empty_arr <- newIdent "empty_arr" $ Prim Bool-      inpacc_ids <- mapM (newParam "inpacc") accrtps-      outszm1id  <- newIdent "szm1" $ Prim int32-      -- 1. let (scan0_ids,map_resids)  = scanomap(scan_lam,nes,map_lam,a_ch)-      let insbnd = mkLet [] (scan0_ids++map_resids) $ Op $-                   Futhark.Screma chvar (Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam') $-                   map paramName strm_inpids-      -- 2. let outerszm1id = chunksize - 1-          outszm1bnd = mkLet [] [outszm1id] $ BasicOp $-                       BinOp (Sub Int32 OverflowUndef)-                       (Futhark.Var $ paramName chunk_param)-                       (constant (1::Int32))-      -- 3. let lasteel_ids = ...-          empty_arr_bnd = mkLet [] [empty_arr] $ BasicOp $ CmpOp (CmpSlt Int32)-                          (Futhark.Var $ identName outszm1id)-                          (constant (0::Int32))-          leltmpbnds= zipWith (\ lid arrid -> mkLet [] [lid] $ BasicOp $-                                              Index (identName arrid) $-                                              fullSlice (identType arrid)-                                              [DimFix $ Futhark.Var $ identName outszm1id]-                              ) lastel_tmp_ids scan0_ids-          lelbnd = mkLet [] lastel_ids $-                   If (Futhark.Var $ identName empty_arr)-                   (mkBody mempty nes)-                   (mkBody (stmsFromList leltmpbnds) $-                    map (Futhark.Var . identName) lastel_tmp_ids) $-                   ifCommon $ map identType lastel_tmp_ids-      -- 4. let strm_resids = map (acc `+`,nes, scan0_ids)-      maplam <- mkMapPlusAccLam (map (Futhark.Var . paramName) inpacc_ids) scan_lam-      let mapbnd = mkLet [] strm_resids $ Op $-                   Futhark.Screma chvar (Futhark.mapSOAC maplam) $-                   map identName scan0_ids-      -- 5. let acc'        = acc + lasteel_ids-      addlelbdy <- mkPlusBnds scan_lam $ map Futhark.Var $-                   map paramName inpacc_ids++map identName lastel_ids-      -- Finally, construct the stream-      let (addlelbnd,addlelres) = (bodyStms addlelbdy, bodyResult addlelbdy)-          strmbdy= mkBody (stmsFromList [insbnd,outszm1bnd,empty_arr_bnd,lelbnd,mapbnd]<>addlelbnd) $-                          addlelres ++ map (Futhark.Var . identName) (strm_resids ++ map_resids)-          strmpar= chunk_param:inpacc_ids++strm_inpids-          strmlam= Lambda strmpar strmbdy (accrtps++loutps)-      return (Stream w (Sequential nes) strmlam inps,-              map paramIdent inpacc_ids)+        -- array result and input IDs of the stream's lambda+        strm_resids <- mapM (newIdent "res") scan_arr_ts+        scan0_ids <- mapM (newIdent "resarr0") scan_arr_ts+        map_resids <- mapM (newIdent "map_res") map_arr_ts +        lastel_ids <- mapM (newIdent "lstel") accrtps+        lastel_tmp_ids <- mapM (newIdent "lstel_tmp") accrtps+        empty_arr <- newIdent "empty_arr" $ Prim Bool+        inpacc_ids <- mapM (newParam "inpacc") accrtps+        outszm1id <- newIdent "szm1" $ Prim int64+        -- 1. let (scan0_ids,map_resids)  = scanomap(scan_lam,nes,map_lam,a_ch)+        let insbnd =+              mkLet [] (scan0_ids ++ map_resids) $+                Op $+                  Futhark.Screma chvar (Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam') $+                    map paramName strm_inpids+            -- 2. let outerszm1id = chunksize - 1+            outszm1bnd =+              mkLet [] [outszm1id] $+                BasicOp $+                  BinOp+                    (Sub Int64 OverflowUndef)+                    (Futhark.Var $ paramName chunk_param)+                    (constant (1 :: Int64))+            -- 3. let lasteel_ids = ...+            empty_arr_bnd =+              mkLet [] [empty_arr] $+                BasicOp $+                  CmpOp+                    (CmpSlt Int64)+                    (Futhark.Var $ identName outszm1id)+                    (constant (0 :: Int64))+            leltmpbnds =+              zipWith+                ( \lid arrid ->+                    mkLet [] [lid] $+                      BasicOp $+                        Index (identName arrid) $+                          fullSlice+                            (identType arrid)+                            [DimFix $ Futhark.Var $ identName outszm1id]+                )+                lastel_tmp_ids+                scan0_ids+            lelbnd =+              mkLet [] lastel_ids $+                If+                  (Futhark.Var $ identName empty_arr)+                  (mkBody mempty nes)+                  ( mkBody (stmsFromList leltmpbnds) $+                      map (Futhark.Var . identName) lastel_tmp_ids+                  )+                  $ ifCommon $ map identType lastel_tmp_ids+        -- 4. let strm_resids = map (acc `+`,nes, scan0_ids)+        maplam <- mkMapPlusAccLam (map (Futhark.Var . paramName) inpacc_ids) scan_lam+        let mapbnd =+              mkLet [] strm_resids $+                Op $+                  Futhark.Screma chvar (Futhark.mapSOAC maplam) $+                    map identName scan0_ids+        -- 5. let acc'        = acc + lasteel_ids+        addlelbdy <-+          mkPlusBnds scan_lam $+            map Futhark.Var $+              map paramName inpacc_ids ++ map identName lastel_ids+        -- Finally, construct the stream+        let (addlelbnd, addlelres) = (bodyStms addlelbdy, bodyResult addlelbdy)+            strmbdy =+              mkBody (stmsFromList [insbnd, outszm1bnd, empty_arr_bnd, lelbnd, mapbnd] <> addlelbnd) $+                addlelres ++ map (Futhark.Var . identName) (strm_resids ++ map_resids)+            strmpar = chunk_param : inpacc_ids ++ strm_inpids+            strmlam = Lambda strmpar strmbdy (accrtps ++ loutps)+        return+          ( Stream w (Sequential nes) strmlam inps,+            map paramIdent inpacc_ids+          )       | Just (reds, _) <- Futhark.isRedomapSOAC form,         Futhark.Reduce comm lamin nes <- Futhark.singleReduce reds -> do-      -- Redomap(+,lam,nes,a) => is translated in strem's body to:-      -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in-      -- 2. let acc'                   = acc + acc0_ids          in-      --    {acc', strm_resids}+        -- Redomap(+,lam,nes,a) => is translated in strem's body to:+        -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in+        -- 2. let acc'                   = acc + acc0_ids          in+        --    {acc', strm_resids} -      let accrtps= take (length nes) $ lambdaReturnType lam-          -- the chunked-outersize of the array result and input types-          loutps' = drop (length nes) loutps-          -- the lambda with proper index-          foldlam = lam'-      -- array result and input IDs of the stream's lambda-      strm_resids <- mapM (newIdent "res") loutps'-      inpacc_ids <- mapM (newParam "inpacc")  accrtps-      acc0_ids   <- mapM (newIdent "acc0"  )  accrtps-      -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in-      let insoac = Futhark.Screma chvar-                   (Futhark.redomapSOAC [Futhark.Reduce comm lamin nes] foldlam) $-                   map paramName strm_inpids-          insbnd = mkLet [] (acc0_ids++strm_resids) $ Op insoac-      -- 2. let acc'     = acc + acc0_ids    in-      addaccbdy <- mkPlusBnds lamin $ map Futhark.Var $-                   map paramName inpacc_ids++map identName acc0_ids-      -- Construct the stream-      let (addaccbnd,addaccres) = (bodyStms addaccbdy, bodyResult addaccbdy)-          strmbdy= mkBody (oneStm insbnd <> addaccbnd) $-                          addaccres ++ map (Futhark.Var . identName) strm_resids-          strmpar= chunk_param:inpacc_ids++strm_inpids-          strmlam= Lambda strmpar strmbdy (accrtps++loutps')-      lam0 <- renameLambda lamin-      return (Stream w (Parallel InOrder comm lam0 nes) strmlam inps, [])+        let accrtps = take (length nes) $ lambdaReturnType lam+            -- the chunked-outersize of the array result and input types+            loutps' = drop (length nes) loutps+            -- the lambda with proper index+            foldlam = lam'+        -- array result and input IDs of the stream's lambda+        strm_resids <- mapM (newIdent "res") loutps'+        inpacc_ids <- mapM (newParam "inpacc") accrtps+        acc0_ids <- mapM (newIdent "acc0") accrtps+        -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in+        let insoac =+              Futhark.Screma+                chvar+                (Futhark.redomapSOAC [Futhark.Reduce comm lamin nes] foldlam)+                $ map paramName strm_inpids+            insbnd = mkLet [] (acc0_ids ++ strm_resids) $ Op insoac+        -- 2. let acc'     = acc + acc0_ids    in+        addaccbdy <-+          mkPlusBnds lamin $+            map Futhark.Var $+              map paramName inpacc_ids ++ map identName acc0_ids+        -- Construct the stream+        let (addaccbnd, addaccres) = (bodyStms addaccbdy, bodyResult addaccbdy)+            strmbdy =+              mkBody (oneStm insbnd <> addaccbnd) $+                addaccres ++ map (Futhark.Var . identName) strm_resids+            strmpar = chunk_param : inpacc_ids ++ strm_inpids+            strmlam = Lambda strmpar strmbdy (accrtps ++ loutps')+        lam0 <- renameLambda lamin+        return (Stream w (Parallel InOrder comm lam0 nes) strmlam inps, [])      -- Otherwise it cannot become a stream.-    _ -> return (soac,[])-    where mkMapPlusAccLam :: (MonadFreshNames m, Bindable lore)-                          => [SubExp] -> Lambda lore -> m (Lambda lore)-          mkMapPlusAccLam accs plus = do-            let (accpars, rempars) = splitAt (length accs) $ lambdaParams plus-                parbnds = zipWith (\ par se -> mkLet [] [paramIdent par]-                                                        (BasicOp $ SubExp se)-                                  ) accpars accs-                plus_bdy = lambdaBody plus-                newlambdy = Body (bodyDec plus_bdy)-                                 (stmsFromList parbnds <> bodyStms plus_bdy)-                                 (bodyResult plus_bdy)-            renameLambda $ Lambda rempars newlambdy $ lambdaReturnType plus+    _ -> return (soac, [])+  where+    mkMapPlusAccLam ::+      (MonadFreshNames m, Bindable lore) =>+      [SubExp] ->+      Lambda lore ->+      m (Lambda lore)+    mkMapPlusAccLam accs plus = do+      let (accpars, rempars) = splitAt (length accs) $ lambdaParams plus+          parbnds =+            zipWith+              ( \par se ->+                  mkLet+                    []+                    [paramIdent par]+                    (BasicOp $ SubExp se)+              )+              accpars+              accs+          plus_bdy = lambdaBody plus+          newlambdy =+            Body+              (bodyDec plus_bdy)+              (stmsFromList parbnds <> bodyStms plus_bdy)+              (bodyResult plus_bdy)+      renameLambda $ Lambda rempars newlambdy $ lambdaReturnType plus -          mkPlusBnds :: (MonadFreshNames m, Bindable lore)-                     => Lambda lore -> [SubExp] -> m (Body lore)-          mkPlusBnds plus accels = do-            plus' <- renameLambda plus-            let parbnds = zipWith (\ par se -> mkLet [] [paramIdent par]-                                                        (BasicOp $ SubExp se)-                                  ) (lambdaParams plus') accels-                body = lambdaBody plus'-            return $ body { bodyStms = stmsFromList parbnds <> bodyStms body }+    mkPlusBnds ::+      (MonadFreshNames m, Bindable lore) =>+      Lambda lore ->+      [SubExp] ->+      m (Body lore)+    mkPlusBnds plus accels = do+      plus' <- renameLambda plus+      let parbnds =+            zipWith+              ( \par se ->+                  mkLet+                    []+                    [paramIdent par]+                    (BasicOp $ SubExp se)+              )+              (lambdaParams plus')+              accels+          body = lambdaBody plus'+      return $ body {bodyStms = stmsFromList parbnds <> bodyStms body}

@@ -1,28 +1,29 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-}+ -- | Abstract Syntax Tree metrics.  This is used in the @futhark test@ -- program, for the @structure@ stanzas. module Futhark.Analysis.Metrics-       ( AstMetrics(..)-       , progMetrics+  ( AstMetrics (..),+    progMetrics, -         -- * Extensibility-       , OpMetrics(..)-       , seen-       , inside-       , MetricsM-       , stmMetrics-       , lambdaMetrics-       ) where+    -- * Extensibility+    OpMetrics (..),+    seen,+    inside,+    MetricsM,+    stmMetrics,+    lambdaMetrics,+  )+where  import Control.Monad.Writer-import Data.Text (Text)-import qualified Data.Text as T import Data.List (tails) import qualified Data.Map.Strict as M-+import Data.Text (Text)+import qualified Data.Text as T import Futhark.IR  -- | AST metrics are simply a collection from identifiable node names@@ -31,15 +32,17 @@  instance Show AstMetrics where   show (AstMetrics m) = unlines $ map metric $ M.toList m-    where metric (k, v) = pretty k ++ " " ++ pretty v+    where+      metric (k, v) = pretty k ++ " " ++ pretty v  instance Read AstMetrics where   readsPrec _ s =     maybe [] success $ mapM onLine $ lines s-    where onLine l = case words l of-                       [k, x] | [(n, "")] <- reads x -> Just (T.pack k, n)-                       _ -> Nothing-          success m = [(AstMetrics $ M.fromList m, "")]+    where+      onLine l = case words l of+        [k, x] | [(n, "")] <- reads x -> Just (T.pack k, n)+        _ -> Nothing+      success m = [(AstMetrics $ M.fromList m, "")]  -- | Compute the metrics for some operation. class OpMetrics op where@@ -59,15 +62,21 @@ actualMetrics :: CountMetrics -> AstMetrics actualMetrics (CountMetrics metrics) =   AstMetrics $ M.fromListWith (+) $ concatMap expand metrics-  where expand (ctx, k) =-          [ (T.intercalate "/" (ctx' ++ [k]), 1)-          | ctx' <- tails $ "" : ctx ]+  where+    expand (ctx, k) =+      [ (T.intercalate "/" (ctx' ++ [k]), 1)+        | ctx' <- tails $ "" : ctx+      ]  -- | This monad is used for computing metrics.  It internally keeps -- track of what we've seen so far.  Use 'seen' to add more stuff.-newtype MetricsM a = MetricsM { runMetricsM :: Writer CountMetrics a }-                   deriving (Monad, Applicative, Functor,-                             MonadWriter CountMetrics)+newtype MetricsM a = MetricsM {runMetricsM :: Writer CountMetrics a}+  deriving+    ( Monad,+      Applicative,+      Functor,+      MonadWriter CountMetrics+    )  -- | Add this node to the current tally. seen :: Text -> MetricsM ()@@ -78,16 +87,19 @@ -- enclosed operation. inside :: Text -> MetricsM () -> MetricsM () inside what m = seen what >> censor addWhat m-  where addWhat (CountMetrics metrics) =-          CountMetrics (map addWhat' metrics)-        addWhat' (ctx, k) = (what : ctx, k)+  where+    addWhat (CountMetrics metrics) =+      CountMetrics (map addWhat' metrics)+    addWhat' (ctx, k) = (what : ctx, k)  -- | Compute the metrics for a program. progMetrics :: OpMetrics (Op lore) => Prog lore -> AstMetrics progMetrics prog =-  actualMetrics $ execWriter $ runMetricsM $ do-  mapM_ funDefMetrics $ progFuns prog-  mapM_ stmMetrics $ progConsts prog+  actualMetrics $+    execWriter $+      runMetricsM $ do+        mapM_ funDefMetrics $ progFuns prog+        mapM_ stmMetrics $ progConsts prog  funDefMetrics :: OpMetrics (Op lore) => FunDef lore -> MetricsM () funDefMetrics = bodyMetrics . funDefBody@@ -102,15 +114,15 @@ expMetrics :: OpMetrics (Op lore) => Exp lore -> MetricsM () expMetrics (BasicOp op) =   seen "BasicOp" >> primOpMetrics op-expMetrics (DoLoop _ _ ForLoop{} body) =+expMetrics (DoLoop _ _ ForLoop {} body) =   inside "DoLoop" $ seen "ForLoop" >> bodyMetrics body-expMetrics (DoLoop _ _ WhileLoop{} body) =+expMetrics (DoLoop _ _ WhileLoop {} body) =   inside "DoLoop" $ seen "WhileLoop" >> bodyMetrics body expMetrics (If _ tb fb _) =   inside "If" $ do     inside "True" $ bodyMetrics tb     inside "False" $ bodyMetrics fb-expMetrics Apply{} =+expMetrics Apply {} =   seen "Apply" expMetrics (Op op) =   opMetrics op@@ -118,23 +130,23 @@ primOpMetrics :: BasicOp -> MetricsM () primOpMetrics (SubExp _) = seen "SubExp" primOpMetrics (Opaque _) = seen "Opaque"-primOpMetrics ArrayLit{} = seen "ArrayLit"-primOpMetrics BinOp{} = seen "BinOp"-primOpMetrics UnOp{} = seen "UnOp"-primOpMetrics ConvOp{} = seen "ConvOp"-primOpMetrics CmpOp{} = seen "ConvOp"-primOpMetrics Assert{} = seen "Assert"-primOpMetrics Index{} = seen "Index"-primOpMetrics Update{} = seen "Update"-primOpMetrics Concat{} = seen "Concat"-primOpMetrics Copy{} = seen "Copy"-primOpMetrics Manifest{} = seen "Manifest"-primOpMetrics Iota{} = seen "Iota"-primOpMetrics Replicate{} = seen "Replicate"-primOpMetrics Scratch{} = seen "Scratch"-primOpMetrics Reshape{} = seen "Reshape"-primOpMetrics Rearrange{} = seen "Rearrange"-primOpMetrics Rotate{} = seen "Rotate"+primOpMetrics ArrayLit {} = seen "ArrayLit"+primOpMetrics BinOp {} = seen "BinOp"+primOpMetrics UnOp {} = seen "UnOp"+primOpMetrics ConvOp {} = seen "ConvOp"+primOpMetrics CmpOp {} = seen "ConvOp"+primOpMetrics Assert {} = seen "Assert"+primOpMetrics Index {} = seen "Index"+primOpMetrics Update {} = seen "Update"+primOpMetrics Concat {} = seen "Concat"+primOpMetrics Copy {} = seen "Copy"+primOpMetrics Manifest {} = seen "Manifest"+primOpMetrics Iota {} = seen "Iota"+primOpMetrics Replicate {} = seen "Replicate"+primOpMetrics Scratch {} = seen "Scratch"+primOpMetrics Reshape {} = seen "Reshape"+primOpMetrics Rearrange {} = seen "Rearrange"+primOpMetrics Rotate {} = seen "Rotate"  -- | Compute metrics for this lambda. lambdaMetrics :: OpMetrics (Op lore) => Lambda lore -> MetricsM ()

@@ -1,31 +1,74 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+ -- | A primitive expression is an expression where the non-leaves are -- primitive operators.  Our representation does not guarantee that -- the expression is type-correct. module Futhark.Analysis.PrimExp-  ( PrimExp (..)-  , evalPrimExp-  , primExpType-  , primExpSizeAtLeast-  , coerceIntPrimExp-  , leafExpTypes-  , true-  , false-  , constFoldPrimExp+  ( PrimExp (..),+    TPrimExp (..),+    isInt8,+    isInt16,+    isInt32,+    isInt64,+    isBool,+    isF32,+    isF64,+    evalPrimExp,+    primExpType,+    primExpSizeAtLeast,+    coerceIntPrimExp,+    leafExpTypes,+    true,+    false,+    constFoldPrimExp, -  , module Futhark.IR.Primitive-  , sExt, zExt-  , (.&&.), (.||.), (.<.), (.<=.), (.>.), (.>=.), (.==.), (.&.), (.|.), (.^.)-  ) where+    -- * Construction+    module Futhark.IR.Primitive,+    NumExp (..),+    IntExp,+    FloatExp (..),+    sExt,+    zExt,+    (.&&.),+    (.||.),+    (.<.),+    (.<=.),+    (.>.),+    (.>=.),+    (.==.),+    (.&.),+    (.|.),+    (.^.),+    bNot,+    sMax32,+    sMin32,+    sMax64,+    sMin64,+    sExt32,+    sExt64,+    zExt32,+    zExt64,+    fMin64,+    fMax64,+  )+where -import           Control.Monad-import           Data.Traversable+import Control.Category+import Control.Monad import qualified Data.Map as M import qualified Data.Set as S--import           Futhark.IR.Prop.Names-import           Futhark.IR.Primitive-import           Futhark.Util.IntegralExp-import           Futhark.Util.Pretty+import qualified Data.Text as T+import Data.Traversable+import Futhark.IR.Primitive+import Futhark.IR.Prop.Names+import Futhark.Util.IntegralExp+import Futhark.Util.Pretty+import GHC.Generics (Generic)+import Language.SexpGrammar as Sexp+import Language.SexpGrammar.Generic+import Prelude hiding (id, (.))  -- | A primitive expression parametrised over the representation of -- free variables.  Note that the 'Functor', 'Traversable', and 'Num'@@ -33,36 +76,28 @@ -- -- Note also that the 'Num' instance assumes 'OverflowUndef' -- semantics!-data PrimExp v = LeafExp v PrimType-               | ValueExp PrimValue-               | BinOpExp BinOp (PrimExp v) (PrimExp v)-               | CmpOpExp CmpOp (PrimExp v) (PrimExp v)-               | UnOpExp UnOp (PrimExp v)-               | ConvOpExp ConvOp (PrimExp v)-               | FunExp String [PrimExp v] PrimType-               deriving (Ord, Show)+data PrimExp v+  = LeafExp v PrimType+  | ValueExp PrimValue+  | BinOpExp BinOp (PrimExp v) (PrimExp v)+  | CmpOpExp CmpOp (PrimExp v) (PrimExp v)+  | UnOpExp UnOp (PrimExp v)+  | ConvOpExp ConvOp (PrimExp v)+  | FunExp String [PrimExp v] PrimType+  deriving (Eq, Ord, Show, Generic) --- The Eq instance upcoerces all integer constants to their largest--- type before comparing for equality.  This is technically not a good--- idea, but solves annoying problems related to the Num instance--- always producing Int64s.-instance Eq v => Eq (PrimExp v) where-  LeafExp x xt == LeafExp y yt = x == y && xt == yt-  ValueExp (IntValue x) == ValueExp (IntValue y) =-    intToInt64 x == intToInt64 y-  ValueExp x == ValueExp y =-    x == y-  BinOpExp xop x1 x2 == BinOpExp yop y1 y2 =-    xop == yop && x1 == y1 && x2 == y2-  CmpOpExp xop x1 x2 == CmpOpExp yop y1 y2 =-    xop == yop && x1 == y1 && x2 == y2-  UnOpExp xop x == UnOpExp yop y =-    xop == yop && x == y-  ConvOpExp xop x == ConvOpExp yop y =-    xop == yop && x == y-  FunExp xf xargs _ == FunExp yf yargs _ =-    xf == yf && xargs == yargs-  _ == _ = False+instance SexpIso v => SexpIso (PrimExp v) where+  sexpIso =+    match $+      With (. Sexp.list (Sexp.el (Sexp.sym "leaf") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $+        With (. Sexp.list (Sexp.el (Sexp.sym "value") >>> Sexp.el sexpIso)) $+          With (. Sexp.list (Sexp.el (Sexp.sym "bin-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $+            With (. Sexp.list (Sexp.el (Sexp.sym "cmp-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $+              With (. Sexp.list (Sexp.el (Sexp.sym "un-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $+                With (. Sexp.list (Sexp.el (Sexp.sym "conv-op") >>> Sexp.el sexpIso >>> Sexp.el sexpIso)) $+                  With+                    (. Sexp.list (Sexp.el (Sexp.sym "fun") >>> Sexp.el (iso T.unpack T.pack . sexpIso) >>> Sexp.el sexpIso >>> Sexp.el sexpIso))+                    End  instance Functor PrimExp where   fmap = fmapDefault@@ -89,48 +124,102 @@ instance FreeIn v => FreeIn (PrimExp v) where   freeIn' = foldMap freeIn' +-- | A 'PrimExp' tagged with a phantom type used to provide type-safe+-- construction.  Does not guarantee that the underlying expression is+-- actually type correct.+newtype TPrimExp t v = TPrimExp {untyped :: PrimExp v}+  deriving (Eq, Ord, Show, Generic)++instance SexpIso v => SexpIso (TPrimExp t v) where+  sexpIso = with $ \e -> sexpIso >>> e++instance Functor (TPrimExp t) where+  fmap = fmapDefault++instance Foldable (TPrimExp t) where+  foldMap = foldMapDefault++instance Traversable (TPrimExp t) where+  traverse f (TPrimExp e) = TPrimExp <$> traverse f e++instance FreeIn v => FreeIn (TPrimExp t v) where+  freeIn' = freeIn' . untyped++-- | This expression is of type 'Int8'.+isInt8 :: PrimExp v -> TPrimExp Int8 v+isInt8 = TPrimExp++-- | This expression is of type 'Int16'.+isInt16 :: PrimExp v -> TPrimExp Int16 v+isInt16 = TPrimExp++-- | This expression is of type 'Int32'.+isInt32 :: PrimExp v -> TPrimExp Int32 v+isInt32 = TPrimExp++-- | This expression is of type 'Int64'.+isInt64 :: PrimExp v -> TPrimExp Int64 v+isInt64 = TPrimExp++-- | This is a boolean expression.+isBool :: PrimExp v -> TPrimExp Bool v+isBool = TPrimExp++-- | This expression is of type 'Float'.+isF32 :: PrimExp v -> TPrimExp Float v+isF32 = TPrimExp++-- | This expression is of type 'Double'.+isF64 :: PrimExp v -> TPrimExp Double v+isF64 = TPrimExp+ -- | True if the 'PrimExp' has at least this many nodes.  This can be -- much more efficient than comparing with 'length' for large -- 'PrimExp's, as this function is lazy. primExpSizeAtLeast :: Int -> PrimExp v -> Bool-primExpSizeAtLeast k = maybe True (>=k) . descend 0-  where descend i _-          | i >= k = Nothing-        descend i LeafExp{} = Just (i+1)-        descend i ValueExp{} = Just (i+1)-        descend i (BinOpExp _ x y) = do x' <- descend (i+1) x-                                        descend x' y-        descend i (CmpOpExp _ x y) = do x' <- descend (i+1) x-                                        descend x' y-        descend i (ConvOpExp _ x) = descend (i+1) x-        descend i (UnOpExp _ x) = descend (i+1) x-        descend i (FunExp _ args _) = foldM descend (i+1) args+primExpSizeAtLeast k = maybe True (>= k) . descend 0+  where+    descend i _+      | i >= k = Nothing+    descend i LeafExp {} = Just (i + 1)+    descend i ValueExp {} = Just (i + 1)+    descend i (BinOpExp _ x y) = do+      x' <- descend (i + 1) x+      descend x' y+    descend i (CmpOpExp _ x y) = do+      x' <- descend (i + 1) x+      descend x' y+    descend i (ConvOpExp _ x) = descend (i + 1) x+    descend i (UnOpExp _ x) = descend (i + 1) x+    descend i (FunExp _ args _) = foldM descend (i + 1) args  -- | Perform quick and dirty constant folding on the top level of a -- PrimExp.  This is necessary because we want to consider -- e.g. equality modulo constant folding. constFoldPrimExp :: PrimExp v -> PrimExp v-constFoldPrimExp (BinOpExp Add{} x y)+constFoldPrimExp (BinOpExp Add {} x y)   | zeroIshExp x = y   | zeroIshExp y = x-constFoldPrimExp (BinOpExp Sub{} x y)+constFoldPrimExp (BinOpExp Sub {} x y)   | zeroIshExp y = x-constFoldPrimExp (BinOpExp Mul{} x y)+constFoldPrimExp (BinOpExp Mul {} x y)   | oneIshExp x = y   | oneIshExp y = x-  | zeroIshExp x, IntType it <- primExpType y =-      ValueExp $ IntValue $ intValue it (0::Int)-  | zeroIshExp y, IntType it <- primExpType x =-      ValueExp $ IntValue $ intValue it (0::Int)-constFoldPrimExp (BinOpExp SDiv{} x y)+  | zeroIshExp x,+    IntType it <- primExpType y =+    ValueExp $ IntValue $ intValue it (0 :: Int)+  | zeroIshExp y,+    IntType it <- primExpType x =+    ValueExp $ IntValue $ intValue it (0 :: Int)+constFoldPrimExp (BinOpExp SDiv {} x y)   | oneIshExp y = x-constFoldPrimExp (BinOpExp SQuot{} x y)+constFoldPrimExp (BinOpExp SQuot {} x y)   | oneIshExp y = x-constFoldPrimExp (BinOpExp UDiv{} x y)+constFoldPrimExp (BinOpExp UDiv {} x y)   | oneIshExp y = x constFoldPrimExp (BinOpExp bop (ValueExp x) (ValueExp y))   | Just z <- doBinOp bop x y =-      ValueExp z+    ValueExp z constFoldPrimExp (BinOpExp LogAnd x y)   | oneIshExp x = y   | oneIshExp y = x@@ -143,124 +232,201 @@   | zeroIshExp y = x constFoldPrimExp e = e --- The Num instance performs a little bit of magic: whenever an--- expression and a constant is combined with a binary operator, the--- type of the constant may be changed to be the type of the--- expression, if they are not already the same.  This permits us to--- write e.g. @x * 4@, where @x@ is an arbitrary PrimExp, and have the--- @4@ converted to the proper primitive type.  We also support--- converting integers to floating point values, but not the other way--- around.  All numeric instances assume unsigned integers for such--- conversions.------ We also perform simple constant folding, in particular to reduce--- expressions to constants so that the above works.  However, it is--- still a bit of a hack.-instance Pretty v => Num (PrimExp v) where-  x + y | Just z <- msum [asIntOp (`Add` OverflowUndef) x y,-                          asFloatOp FAdd x y] = constFoldPrimExp z-        | otherwise = numBad "+" (x,y)+-- | The class of numeric types that can be used for constructing+-- 'TPrimExp's.+class NumExp t where+  -- | Construct a typed expression from an integer.+  fromInteger' :: Integer -> TPrimExp t v -  x - y | Just z <- msum [asIntOp (`Sub` OverflowUndef) x y,-                          asFloatOp FSub x y] = constFoldPrimExp z-        | otherwise = numBad "-" (x,y)+-- | The class of integer types that can be used for constructing+-- 'TPrimExp's.+class NumExp t => IntExp t -  x * y | Just z <- msum [asIntOp (`Mul` OverflowUndef) x y,-                          asFloatOp FMul x y] = constFoldPrimExp z-        | otherwise = numBad "*" (x,y)+instance NumExp Int8 where+  fromInteger' = isInt8 . ValueExp . IntValue . Int8Value . fromInteger -  abs x | IntType t <- primExpType x = UnOpExp (Abs t) x-        | FloatType t <- primExpType x = UnOpExp (FAbs t) x-        | otherwise = numBad "abs" x+instance IntExp Int8 -  signum x | IntType t <- primExpType x = UnOpExp (SSignum t) x-           | otherwise = numBad "signum" x+instance NumExp Int16 where+  fromInteger' = isInt16 . ValueExp . IntValue . Int16Value . fromInteger -  fromInteger = fromInt32 . fromInteger+instance IntExp Int16 -instance Pretty v => Fractional (PrimExp v) where-  x / y | Just z <- msum [asFloatOp FDiv x y] = constFoldPrimExp z-        | otherwise = numBad "/" (x,y)+instance NumExp Int32 where+  fromInteger' = isInt32 . ValueExp . IntValue . Int32Value . fromInteger -  fromRational = ValueExp . FloatValue . Float64Value . fromRational+instance IntExp Int32 -instance Pretty v => IntegralExp (PrimExp v) where-  x `div` y | Just z <- msum [asIntOp (`SDiv` Unsafe) x y,-                              asFloatOp FDiv x y] =-                constFoldPrimExp z-            | otherwise = numBad "div" (x,y)+instance NumExp Int64 where+  fromInteger' = isInt64 . ValueExp . IntValue . Int64Value . fromInteger -  x `mod` y | Just z <- msum [asIntOp (`SMod` Unsafe) x y] = z-            | otherwise = numBad "mod" (x,y)+instance IntExp Int64 -  x `quot` y | oneIshExp y = x-             | Just z <- msum [asIntOp (`SQuot` Unsafe) x y] = constFoldPrimExp z-             | otherwise = numBad "quot" (x,y)+-- | The class of floating-point types that can be used for+-- constructing 'TPrimExp's.+class NumExp t => FloatExp t where+  -- | Construct a typed expression from a rational.+  fromRational' :: Rational -> TPrimExp t v -  x `rem` y | Just z <- msum [asIntOp (`SRem` Unsafe) x y] = constFoldPrimExp z-            | otherwise = numBad "rem" (x,y)+instance NumExp Float where+  fromInteger' = TPrimExp . ValueExp . FloatValue . Float32Value . fromInteger -  x `divUp` y | Just z <- msum [asIntOp (`SDivUp` Unsafe) x y] =-                  constFoldPrimExp z-              | otherwise = numBad "divRoundingUp" (x,y)+instance NumExp Double where+  fromInteger' = TPrimExp . ValueExp . FloatValue . Float64Value . fromInteger -  sgn (ValueExp (IntValue i)) = Just $ signum $ valueIntegral i-  sgn _ = Nothing+instance FloatExp Float where+  fromRational' = TPrimExp . ValueExp . FloatValue . Float32Value . fromRational -  fromInt8  = ValueExp . IntValue . Int8Value-  fromInt16 = ValueExp . IntValue . Int16Value-  fromInt32 = ValueExp . IntValue . Int32Value-  fromInt64 = ValueExp . IntValue . Int64Value+instance FloatExp Double where+  fromRational' = TPrimExp . ValueExp . FloatValue . Float64Value . fromRational +instance (NumExp t, Pretty v) => Num (TPrimExp t v) where+  TPrimExp x + TPrimExp y+    | Just z <-+        msum+          [ asIntOp (`Add` OverflowUndef) x y,+            asFloatOp FAdd x y+          ] =+      TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "+" (x, y)++  TPrimExp x - TPrimExp y+    | Just z <-+        msum+          [ asIntOp (`Sub` OverflowUndef) x y,+            asFloatOp FSub x y+          ] =+      TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "-" (x, y)++  TPrimExp x * TPrimExp y+    | Just z <-+        msum+          [ asIntOp (`Mul` OverflowUndef) x y,+            asFloatOp FMul x y+          ] =+      TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "*" (x, y)++  abs (TPrimExp x)+    | IntType t <- primExpType x = TPrimExp $ UnOpExp (Abs t) x+    | FloatType t <- primExpType x = TPrimExp $ UnOpExp (FAbs t) x+    | otherwise = numBad "abs" x++  signum (TPrimExp x)+    | IntType t <- primExpType x = TPrimExp $ UnOpExp (SSignum t) x+    | otherwise = numBad "signum" x++  fromInteger = fromInteger'++instance (FloatExp t, Pretty v) => Fractional (TPrimExp t v) where+  TPrimExp x / TPrimExp y+    | Just z <- msum [asFloatOp FDiv x y] = TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "/" (x, y)++  fromRational = fromRational'++instance (IntExp t, Pretty v) => IntegralExp (TPrimExp t v) where+  TPrimExp x `div` TPrimExp y+    | Just z <-+        msum+          [ asIntOp (`SDiv` Unsafe) x y,+            asFloatOp FDiv x y+          ] =+      TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "div" (x, y)++  TPrimExp x `mod` TPrimExp y+    | Just z <- msum [asIntOp (`SMod` Unsafe) x y] =+      TPrimExp z+    | otherwise = numBad "mod" (x, y)++  TPrimExp x `quot` TPrimExp y+    | oneIshExp y = TPrimExp x+    | Just z <- msum [asIntOp (`SQuot` Unsafe) x y] =+      TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "quot" (x, y)++  TPrimExp x `rem` TPrimExp y+    | Just z <- msum [asIntOp (`SRem` Unsafe) x y] =+      TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "rem" (x, y)++  TPrimExp x `divUp` TPrimExp y+    | Just z <- msum [asIntOp (`SDivUp` Unsafe) x y] =+      TPrimExp $ constFoldPrimExp z+    | otherwise = numBad "divRoundingUp" (x, y)++  sgn (TPrimExp (ValueExp (IntValue i))) = Just $ signum $ valueIntegral i+  sgn _ = Nothing+ -- | Lifted logical conjunction.-(.&&.) :: PrimExp v -> PrimExp v -> PrimExp v-x .&&. y = constFoldPrimExp $ BinOpExp LogAnd x y+(.&&.) :: TPrimExp Bool v -> TPrimExp Bool v -> TPrimExp Bool v+TPrimExp x .&&. TPrimExp y = TPrimExp $ constFoldPrimExp $ BinOpExp LogAnd x y  -- | Lifted logical conjunction.-(.||.) :: PrimExp v -> PrimExp v -> PrimExp v-x .||. y = constFoldPrimExp $ BinOpExp LogOr x y+(.||.) :: TPrimExp Bool v -> TPrimExp Bool v -> TPrimExp Bool v+TPrimExp x .||. TPrimExp y = TPrimExp $ constFoldPrimExp $ BinOpExp LogOr x y  -- | Lifted relational operators; assuming signed numbers in case of -- integers.-(.<.), (.>.), (.<=.), (.>=.), (.==.) :: PrimExp v -> PrimExp v -> PrimExp v-x .<. y = constFoldPrimExp $-          CmpOpExp cmp x y where cmp = case primExpType x of-                                         IntType t -> CmpSlt $ t `min` primExpIntType y-                                         FloatType t -> FCmpLt t-                                         _ -> CmpLlt-x .<=. y = constFoldPrimExp $-           CmpOpExp cmp x y where cmp = case primExpType x of-                                          IntType t -> CmpSle $ t `min` primExpIntType y-                                          FloatType t -> FCmpLe t-                                          _ -> CmpLle-x .==. y = constFoldPrimExp $-           CmpOpExp (CmpEq $ primExpType x `min` primExpType y) x y+(.<.), (.>.), (.<=.), (.>=.), (.==.) :: TPrimExp t v -> TPrimExp t v -> TPrimExp Bool v+TPrimExp x .<. TPrimExp y =+  TPrimExp $+    constFoldPrimExp $+      CmpOpExp cmp x y+  where+    cmp = case primExpType x of+      IntType t -> CmpSlt t+      FloatType t -> FCmpLt t+      _ -> CmpLlt+TPrimExp x .<=. TPrimExp y =+  TPrimExp $+    constFoldPrimExp $+      CmpOpExp cmp x y+  where+    cmp = case primExpType x of+      IntType t -> CmpSle t+      FloatType t -> FCmpLe t+      _ -> CmpLle+TPrimExp x .==. TPrimExp y =+  TPrimExp $+    constFoldPrimExp $+      CmpOpExp (CmpEq $ primExpType x `min` primExpType y) x y x .>. y = y .<. x x .>=. y = y .<=. x  -- | Lifted bitwise operators.-(.&.), (.|.), (.^.) :: PrimExp v -> PrimExp v -> PrimExp v-x .&. y = constFoldPrimExp $-          BinOpExp (And $ primExpIntType x `min` primExpIntType y) x y-x .|. y = constFoldPrimExp $-          BinOpExp (Or $ primExpIntType x `min` primExpIntType y) x y-x .^. y = constFoldPrimExp $-          BinOpExp (Xor $ primExpIntType x `min` primExpIntType y) x y+(.&.), (.|.), (.^.) :: TPrimExp t v -> TPrimExp t v -> TPrimExp t v+TPrimExp x .&. TPrimExp y =+  TPrimExp $+    constFoldPrimExp $+      BinOpExp (And $ primExpIntType x) x y+TPrimExp x .|. TPrimExp y =+  TPrimExp $+    constFoldPrimExp $+      BinOpExp (Or $ primExpIntType x) x y+TPrimExp x .^. TPrimExp y =+  TPrimExp $+    constFoldPrimExp $+      BinOpExp (Xor $ primExpIntType x) x y  infix 4 .==., .<., .>., .<=., .>=.+ infixr 3 .&&.+ infixr 2 .||. --- | Smart constructor for sign extension that does a bit of constant--- folding.+-- | Untyped smart constructor for sign extension that does a bit of+-- constant folding. sExt :: IntType -> PrimExp v -> PrimExp v sExt it (ValueExp (IntValue v)) = ValueExp $ IntValue $ doSExt v it sExt it e   | primExpIntType e == it = e   | otherwise = ConvOpExp (SExt (primExpIntType e) it) e --- | Smart constructor for zero extension that does a bit of constant--- folding.+-- | Untyped smart constructor for zero extension that does a bit of+-- constant folding. zExt :: IntType -> PrimExp v -> PrimExp v zExt it (ValueExp (IntValue v)) = ValueExp $ IntValue $ doZExt v it zExt it e@@ -269,50 +435,14 @@  asIntOp :: (IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v) asIntOp f x y-  -- If either of the operands is a constant, then we prefer the type-  -- of the other operand.  This lets us use literals via fromInteger-  -- without imposing a specific type.-  | ValueExp{} <- x,-    IntType y_t <- primExpType y,-    Just x' <- asIntExp y_t x = Just $ BinOpExp (f y_t) x' y-  | ValueExp{} <- y,-    IntType x_t <- primExpType x,-    Just y' <- asIntExp x_t y = Just $ BinOpExp (f x_t) x y'--  -- Otherwise prefer the type of the leftmost operand.-  | IntType t <- primExpType x,-    Just y' <- asIntExp t y = Just $ BinOpExp (f t) x y'-  | IntType t <- primExpType y,-    Just x' <- asIntExp t x = Just $ BinOpExp (f t) x' y-+  | IntType x_t <- primExpType x = Just $ BinOpExp (f x_t) x y   | otherwise = Nothing -asIntExp :: IntType -> PrimExp v -> Maybe (PrimExp v)-asIntExp t e-  | primExpType e == IntType t = Just e-asIntExp t (ValueExp (IntValue v)) =-  Just $ ValueExp $ IntValue $ doSExt v t-asIntExp _ _ =-  Nothing- asFloatOp :: (FloatType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v) asFloatOp f x y-  | FloatType t <- primExpType x,-    Just y' <- asFloatExp t y = Just $ BinOpExp (f t) x y'-  | FloatType t <- primExpType y,-    Just x' <- asFloatExp t x = Just $ BinOpExp (f t) x' y+  | FloatType t <- primExpType x = Just $ BinOpExp (f t) x y   | otherwise = Nothing -asFloatExp :: FloatType -> PrimExp v -> Maybe (PrimExp v)-asFloatExp t e-  | primExpType e == FloatType t = Just e-asFloatExp t (ValueExp (FloatValue v)) =-  Just $ ValueExp $ FloatValue $ doFPConv v t-asFloatExp t (ValueExp (IntValue v)) =-  Just $ ValueExp $ FloatValue $ doSIToFP v t-asFloatExp _ _ =-  Nothing- numBad :: Pretty a => String -> a -> b numBad s x =   error $ "Invalid argument to PrimExp method " ++ s ++ ": " ++ pretty x@@ -325,11 +455,11 @@ evalPrimExp f (BinOpExp op x y) = do   x' <- evalPrimExp f x   y' <- evalPrimExp f y-  maybe (evalBad op (x,y)) return $ doBinOp op x' y'+  maybe (evalBad op (x, y)) return $ doBinOp op x' y' evalPrimExp f (CmpOpExp op x y) = do   x' <- evalPrimExp f x   y' <- evalPrimExp f y-  maybe (evalBad op (x,y)) (return . BoolValue) $ doCmpOp op x' y'+  maybe (evalBad op (x, y)) (return . BoolValue) $ doCmpOp op x' y' evalPrimExp f (UnOpExp op x) = do   x' <- evalPrimExp f x   maybe (evalBad op x) return $ doUnOp op x'@@ -338,60 +468,113 @@   maybe (evalBad op x) return $ doConvOp op x' evalPrimExp f (FunExp h args _) = do   args' <- mapM (evalPrimExp f) args-  maybe (evalBad h args) return $ do (_, _, fun) <- M.lookup h primFuns-                                     fun args'+  maybe (evalBad h args) return $ do+    (_, _, fun) <- M.lookup h primFuns+    fun args'  evalBad :: (Pretty a, Pretty b, MonadFail m) => a -> b -> m c-evalBad op arg = fail $ "evalPrimExp: Type error when applying " ++-                 pretty op ++ " to " ++ pretty arg+evalBad op arg =+  fail $+    "evalPrimExp: Type error when applying "+      ++ pretty op+      ++ " to "+      ++ pretty arg  -- | The type of values returned by a 'PrimExp'.  This function -- returning does not imply that the 'PrimExp' is type-correct. primExpType :: PrimExp v -> PrimType-primExpType (LeafExp _ t)     = t-primExpType (ValueExp v)      = primValueType v+primExpType (LeafExp _ t) = t+primExpType (ValueExp v) = primValueType v primExpType (BinOpExp op _ _) = binOpType op-primExpType CmpOpExp{}        = Bool-primExpType (UnOpExp op _)    = unOpType op-primExpType (ConvOpExp op _)  = snd $ convOpType op-primExpType (FunExp _ _ t)    = t+primExpType CmpOpExp {} = Bool+primExpType (UnOpExp op _) = unOpType op+primExpType (ConvOpExp op _) = snd $ convOpType op+primExpType (FunExp _ _ t) = t  -- | Is the expression a constant zero of some sort? zeroIshExp :: PrimExp v -> Bool zeroIshExp (ValueExp v) = zeroIsh v-zeroIshExp _            = False+zeroIshExp _ = False  -- | Is the expression a constant one of some sort? oneIshExp :: PrimExp v -> Bool oneIshExp (ValueExp v) = oneIsh v-oneIshExp _            = False+oneIshExp _ = False  -- | If the given 'PrimExp' is a constant of the wrong integer type, -- coerce it to the given integer type.  This is a workaround for an -- issue in the 'Num' instance. coerceIntPrimExp :: IntType -> PrimExp v -> PrimExp v coerceIntPrimExp t (ValueExp (IntValue v)) = ValueExp $ IntValue $ doSExt v t-coerceIntPrimExp _ e                       = e+coerceIntPrimExp _ e = e  primExpIntType :: PrimExp v -> IntType-primExpIntType e = case primExpType e of IntType t -> t-                                         _         -> Int64+primExpIntType e = case primExpType e of+  IntType t -> t+  _ -> Int64  -- | Boolean-valued PrimExps.-true, false :: PrimExp v-true = ValueExp $ BoolValue True-false = ValueExp $ BoolValue False+true, false :: TPrimExp Bool v+true = TPrimExp $ ValueExp $ BoolValue True+false = TPrimExp $ ValueExp $ BoolValue False +-- | Boolean negation smart constructor.+bNot :: TPrimExp Bool v -> TPrimExp Bool v+bNot = TPrimExp . UnOpExp Not . untyped++-- | SMax on 32-bit integers.+sMax32 :: TPrimExp Int32 v -> TPrimExp Int32 v -> TPrimExp Int32 v+sMax32 x y = TPrimExp $ BinOpExp (SMax Int32) (untyped x) (untyped y)++-- | SMin on 32-bit integers.+sMin32 :: TPrimExp Int32 v -> TPrimExp Int32 v -> TPrimExp Int32 v+sMin32 x y = TPrimExp $ BinOpExp (SMin Int32) (untyped x) (untyped y)++-- | SMax on 64-bit integers.+sMax64 :: TPrimExp Int64 v -> TPrimExp Int64 v -> TPrimExp Int64 v+sMax64 x y = TPrimExp $ BinOpExp (SMax Int64) (untyped x) (untyped y)++-- | SMin on 64-bit integers.+sMin64 :: TPrimExp Int64 v -> TPrimExp Int64 v -> TPrimExp Int64 v+sMin64 x y = TPrimExp $ BinOpExp (SMin Int64) (untyped x) (untyped y)++-- | Sign-extend to 32 bit integer.+sExt32 :: IntExp t => TPrimExp t v -> TPrimExp Int32 v+sExt32 = isInt32 . sExt Int32 . untyped++-- | Sign-extend to 64 bit integer.+sExt64 :: IntExp t => TPrimExp t v -> TPrimExp Int64 v+sExt64 = isInt64 . sExt Int64 . untyped++-- | Zero-extend to 32 bit integer.+zExt32 :: IntExp t => TPrimExp t v -> TPrimExp Int32 v+zExt32 = isInt32 . zExt Int32 . untyped++-- | Zero-extend to 64 bit integer.+zExt64 :: IntExp t => TPrimExp t v -> TPrimExp Int64 v+zExt64 = isInt64 . zExt Int64 . untyped++-- | 64-bit float minimum.+fMin64 :: TPrimExp Double v -> TPrimExp Double v -> TPrimExp Double v+fMin64 x y = TPrimExp $ BinOpExp (FMin Float64) (untyped x) (untyped y)++-- | 64-bit float maximum.+fMax64 :: TPrimExp Double v -> TPrimExp Double v -> TPrimExp Double v+fMax64 x y = TPrimExp $ BinOpExp (FMax Float64) (untyped x) (untyped y)+ -- Prettyprinting instances  instance Pretty v => Pretty (PrimExp v) where-  ppr (LeafExp v _)     = ppr v-  ppr (ValueExp v)      = ppr v+  ppr (LeafExp v _) = ppr v+  ppr (ValueExp v) = ppr v   ppr (BinOpExp op x y) = ppr op <+> parens (ppr x) <+> parens (ppr y)   ppr (CmpOpExp op x y) = ppr op <+> parens (ppr x) <+> parens (ppr y)-  ppr (ConvOpExp op x)  = ppr op <+> parens (ppr x)-  ppr (UnOpExp op x)    = ppr op <+> parens (ppr x)+  ppr (ConvOpExp op x) = ppr op <+> parens (ppr x)+  ppr (UnOpExp op x) = ppr op <+> parens (ppr x)   ppr (FunExp h args _) = text h <+> parens (commasep $ map ppr args)++instance Pretty v => Pretty (TPrimExp t v) where+  ppr = ppr . untyped  -- | Produce a mapping from the leaves of the 'PrimExp' to their -- designated types.

@@ -1,29 +1,33 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | Converting back and forth between 'PrimExp's.  Use the 'ToExp' -- instance to convert to Futhark expressions. module Futhark.Analysis.PrimExp.Convert-  (-    primExpFromExp-  , primExpFromSubExp-  , primExpFromSubExpM-  , replaceInPrimExp-  , replaceInPrimExpM-  , substituteInPrimExp-  , primExpSlice-  , subExpSlice+  ( primExpFromExp,+    primExpFromSubExp,+    pe32,+    le32,+    pe64,+    le64,+    primExpFromSubExpM,+    replaceInPrimExp,+    replaceInPrimExpM,+    substituteInPrimExp,+    primExpSlice,+    subExpSlice,      -- * Module reexport-    , module Futhark.Analysis.PrimExp-  ) where+    module Futhark.Analysis.PrimExp,+  )+where  import qualified Control.Monad.Fail as Fail-import           Control.Monad.Identity+import Control.Monad.Identity import qualified Data.Map.Strict as M-import           Data.Maybe--import           Futhark.Analysis.PrimExp-import           Futhark.Construct-import           Futhark.IR+import Data.Maybe+import Futhark.Analysis.PrimExp+import Futhark.Construct+import Futhark.IR  instance ToExp v => ToExp (PrimExp v) where   toExp (BinOpExp op x y) =@@ -37,18 +41,25 @@   toExp (ValueExp v) =     return $ BasicOp $ SubExp $ Constant v   toExp (FunExp h args t) =-    Apply (nameFromString h) <$> args' <*> pure [primRetType t] <*>-    pure (Safe, mempty, [])-    where args' = zip <$> mapM (toSubExp "apply_arg") args <*> pure (repeat Observe)+    Apply (nameFromString h) <$> args' <*> pure [primRetType t]+      <*> pure (Safe, mempty, [])+    where+      args' = zip <$> mapM (toSubExp "apply_arg") args <*> pure (repeat Observe)   toExp (LeafExp v _) =     toExp v +instance ToExp v => ToExp (TPrimExp t v) where+  toExp = toExp . untyped+ -- | Convert an expression to a 'PrimExp'.  The provided function is -- used to convert expressions that are not trivially 'PrimExp's. -- This includes constants and variable names, which are passed as -- t'SubExp's.-primExpFromExp :: (Fail.MonadFail m, Decorations lore) =>-                  (VName -> m (PrimExp v)) -> Exp lore -> m (PrimExp v)+primExpFromExp ::+  (Fail.MonadFail m, Decorations lore) =>+  (VName -> m (PrimExp v)) ->+  Exp lore ->+  m (PrimExp v) primExpFromExp f (BasicOp (BinOp op x y)) =   BinOpExp op <$> primExpFromSubExpM f x <*> primExpFromSubExpM f y primExpFromExp f (BasicOp (CmpOp op x y)) =@@ -60,8 +71,9 @@ primExpFromExp f (BasicOp (SubExp se)) =   primExpFromSubExpM f se primExpFromExp f (Apply fname args ts _)-  | isBuiltInFunction fname, [Prim t] <- map declExtTypeOf ts =-      FunExp (nameToString fname) <$> mapM (primExpFromSubExpM f . fst) args <*> pure t+  | isBuiltInFunction fname,+    [Prim t] <- map declExtTypeOf ts =+    FunExp (nameToString fname) <$> mapM (primExpFromSubExpM f . fst) args <*> pure t primExpFromExp _ _ = fail "Not a PrimExp"  -- | Like 'primExpFromExp', but for a t'SubExp'.@@ -71,20 +83,38 @@  -- | Convert t'SubExp's of a given type. primExpFromSubExp :: PrimType -> SubExp -> PrimExp VName-primExpFromSubExp t (Var v)      = LeafExp v t+primExpFromSubExp t (Var v) = LeafExp v t primExpFromSubExp _ (Constant v) = ValueExp v +-- | Shorthand for constructing a 'TPrimExp' of type 'Int32'.+pe32 :: SubExp -> TPrimExp Int32 VName+pe32 = isInt32 . primExpFromSubExp int32++-- | Shorthand for constructing a 'TPrimExp' of type 'Int32', from a leaf.+le32 :: a -> TPrimExp Int32 a+le32 = isInt32 . flip LeafExp int32++-- | Shorthand for constructing a 'TPrimExp' of type 'Int64'.+pe64 :: SubExp -> TPrimExp Int64 VName+pe64 = isInt64 . primExpFromSubExp int64++-- | Shorthand for constructing a 'TPrimExp' of type 'Int64', from a leaf.+le64 :: a -> TPrimExp Int64 a+le64 = isInt64 . flip LeafExp int64+ -- | Applying a monadic transformation to the leaves in a 'PrimExp'.-replaceInPrimExpM :: Monad m =>-                     (a -> PrimType -> m (PrimExp b)) ->-                     PrimExp a -> m (PrimExp b)+replaceInPrimExpM ::+  Monad m =>+  (a -> PrimType -> m (PrimExp b)) ->+  PrimExp a ->+  m (PrimExp b) replaceInPrimExpM f (LeafExp v pt) =   f v pt replaceInPrimExpM _ (ValueExp v) =   return $ ValueExp v replaceInPrimExpM f (BinOpExp bop pe1 pe2) =-  constFoldPrimExp <$>-  (BinOpExp bop <$> replaceInPrimExpM f pe1 <*> replaceInPrimExpM f pe2)+  constFoldPrimExp+    <$> (BinOpExp bop <$> replaceInPrimExpM f pe1 <*> replaceInPrimExpM f pe2) replaceInPrimExpM f (CmpOpExp cop pe1 pe2) =   CmpOpExp cop <$> replaceInPrimExpM f pe1 <*> replaceInPrimExpM f pe2 replaceInPrimExpM f (UnOpExp uop pe) =@@ -95,21 +125,27 @@   FunExp h <$> mapM (replaceInPrimExpM f) args <*> pure t  -- | As 'replaceInPrimExpM', but in the identity monad.-replaceInPrimExp :: (a -> PrimType -> PrimExp b) ->-                    PrimExp a -> PrimExp b+replaceInPrimExp ::+  (a -> PrimType -> PrimExp b) ->+  PrimExp a ->+  PrimExp b replaceInPrimExp f e = runIdentity $ replaceInPrimExpM f' e-  where f' x y = return $ f x y+  where+    f' x y = return $ f x y  -- | Substituting names in a PrimExp with other PrimExps-substituteInPrimExp :: Ord v => M.Map v (PrimExp v)-                    -> PrimExp v -> PrimExp v+substituteInPrimExp ::+  Ord v =>+  M.Map v (PrimExp v) ->+  PrimExp v ->+  PrimExp v substituteInPrimExp tab = replaceInPrimExp $ \v t ->   fromMaybe (LeafExp v t) $ M.lookup v tab  -- | Convert a 'SubExp' slice to a 'PrimExp' slice.-primExpSlice :: Slice SubExp -> Slice (PrimExp VName)-primExpSlice = map $ fmap $ primExpFromSubExp int32+primExpSlice :: Slice SubExp -> Slice (TPrimExp Int64 VName)+primExpSlice = map $ fmap pe64  -- | Convert a 'PrimExp' slice to a 'SubExp' slice.-subExpSlice :: MonadBinder m => Slice (PrimExp VName) -> m (Slice SubExp)+subExpSlice :: MonadBinder m => Slice (TPrimExp Int64 VName) -> m (Slice SubExp) subExpSlice = mapM $ traverse $ toSubExp "slice"

@@ -1,69 +1,73 @@ -- | Generalization (anti-unification) of 'PrimExp's. module Futhark.Analysis.PrimExp.Generalize-  (-    leastGeneralGeneralization-  ) where--import           Data.List (elemIndex)+  ( leastGeneralGeneralization,+  )+where -import           Futhark.Analysis.PrimExp-import           Futhark.IR.Syntax.Core (Ext(..))+import Data.List (elemIndex)+import Futhark.Analysis.PrimExp+import Futhark.IR.Syntax.Core (Ext (..))  -- | Generalize two 'PrimExp's of the the same type.-leastGeneralGeneralization :: (Eq v) => [(PrimExp v, PrimExp v)] -> PrimExp v -> PrimExp v ->-                              (PrimExp (Ext v), [(PrimExp v, PrimExp v)])+leastGeneralGeneralization ::+  (Eq v) =>+  [(PrimExp v, PrimExp v)] ->+  PrimExp v ->+  PrimExp v ->+  (PrimExp (Ext v), [(PrimExp v, PrimExp v)]) leastGeneralGeneralization m exp1@(LeafExp v1 t1) exp2@(LeafExp v2 _) =-  if v1 == v2 then-    (LeafExp (Free v1) t1, m)-  else-    generalize m exp1 exp2+  if v1 == v2+    then (LeafExp (Free v1) t1, m)+    else generalize m exp1 exp2 leastGeneralGeneralization m exp1@(ValueExp v1) exp2@(ValueExp v2) =-  if v1 == v2 then-    (ValueExp v1, m)-  else-    generalize m exp1 exp2+  if v1 == v2+    then (ValueExp v1, m)+    else generalize m exp1 exp2 leastGeneralGeneralization m exp1@(BinOpExp op1 e11 e12) exp2@(BinOpExp op2 e21 e22) =-  if op1 == op2 then-    let (e1, m1) = leastGeneralGeneralization m e11 e21-        (e2, m2) = leastGeneralGeneralization m1 e12 e22-    in (BinOpExp op1 e1 e2, m2)-  else-    generalize m exp1 exp2+  if op1 == op2+    then+      let (e1, m1) = leastGeneralGeneralization m e11 e21+          (e2, m2) = leastGeneralGeneralization m1 e12 e22+       in (BinOpExp op1 e1 e2, m2)+    else generalize m exp1 exp2 leastGeneralGeneralization m exp1@(CmpOpExp op1 e11 e12) exp2@(CmpOpExp op2 e21 e22) =-  if op1 == op2 then-    let (e1, m1) = leastGeneralGeneralization m e11 e21-        (e2, m2) = leastGeneralGeneralization m1 e12 e22-    in (CmpOpExp op1 e1 e2, m2)-  else-    generalize m exp1 exp2+  if op1 == op2+    then+      let (e1, m1) = leastGeneralGeneralization m e11 e21+          (e2, m2) = leastGeneralGeneralization m1 e12 e22+       in (CmpOpExp op1 e1 e2, m2)+    else generalize m exp1 exp2 leastGeneralGeneralization m exp1@(UnOpExp op1 e1) exp2@(UnOpExp op2 e2) =-  if op1 == op2 then-    let (e, m1) = leastGeneralGeneralization m e1 e2-    in (UnOpExp op1 e, m1)-  else-    generalize m exp1 exp2+  if op1 == op2+    then+      let (e, m1) = leastGeneralGeneralization m e1 e2+       in (UnOpExp op1 e, m1)+    else generalize m exp1 exp2 leastGeneralGeneralization m exp1@(ConvOpExp op1 e1) exp2@(ConvOpExp op2 e2) =-  if op1 == op2 then-    let (e, m1) = leastGeneralGeneralization m e1 e2-    in (ConvOpExp op1 e, m1)-  else-    generalize m exp1 exp2+  if op1 == op2+    then+      let (e, m1) = leastGeneralGeneralization m e1 e2+       in (ConvOpExp op1 e, m1)+    else generalize m exp1 exp2 leastGeneralGeneralization m exp1@(FunExp s1 args1 t1) exp2@(FunExp s2 args2 _) =-  if s1 == s2 && length args1 == length args2 then-    let (args, m') =-          foldl (\(arg_acc, m_acc) (a1, a2) ->-                    let (a, m'') = leastGeneralGeneralization m_acc a1 a2-                    in  (a : arg_acc, m'')-                ) ([], m) (zip args1 args2)-    in (FunExp s1 (reverse args) t1, m')-  else-    generalize m exp1 exp2+  if s1 == s2 && length args1 == length args2+    then+      let (args, m') =+            foldl+              ( \(arg_acc, m_acc) (a1, a2) ->+                  let (a, m'') = leastGeneralGeneralization m_acc a1 a2+                   in (a : arg_acc, m'')+              )+              ([], m)+              (zip args1 args2)+       in (FunExp s1 (reverse args) t1, m')+    else generalize m exp1 exp2 leastGeneralGeneralization m exp1 exp2 =   generalize m exp1 exp2  generalize :: Eq v => [(PrimExp v, PrimExp v)] -> PrimExp v -> PrimExp v -> (PrimExp (Ext v), [(PrimExp v, PrimExp v)]) generalize m exp1 exp2 =   let t = primExpType exp1-  in case elemIndex (exp1, exp2) m of-       Just i -> (LeafExp (Ext i) t, m)-       Nothing -> (LeafExp (Ext $ length m) t, m ++ [(exp1, exp2)])+   in case elemIndex (exp1, exp2) m of+        Just i -> (LeafExp (Ext i) t, m)+        Nothing -> (LeafExp (Ext $ length m) t, m ++ [(exp1, exp2)])

@@ -1,39 +1,46 @@ {-# LANGUAGE FlexibleContexts #-}+ -- | Defines simplification functions for 'PrimExp's.-module Futhark.Analysis.PrimExp.Simplify-  (simplifyPrimExp, simplifyExtPrimExp)-where+module Futhark.Analysis.PrimExp.Simplify (simplifyPrimExp, simplifyExtPrimExp) where -import           Futhark.Analysis.PrimExp-import           Futhark.Optimise.Simplify.Engine as Engine-import           Futhark.IR+import Futhark.Analysis.PrimExp+import Futhark.IR+import Futhark.Optimise.Simplify.Engine as Engine  -- | Simplify a 'PrimExp', including copy propagation.  If a 'LeafExp' -- refers to a name that is a 'Constant', the node turns into a -- 'ValueExp'.-simplifyPrimExp :: SimplifiableLore lore =>-                   PrimExp VName -> SimpleM lore (PrimExp VName)+simplifyPrimExp ::+  SimplifiableLore lore =>+  PrimExp VName ->+  SimpleM lore (PrimExp VName) simplifyPrimExp = simplifyAnyPrimExp onLeaf-  where onLeaf v pt = do-          se <- simplify $ Var v-          case se of-            Var v' -> return $ LeafExp v' pt-            Constant pv -> return $ ValueExp pv+  where+    onLeaf v pt = do+      se <- simplify $ Var v+      case se of+        Var v' -> return $ LeafExp v' pt+        Constant pv -> return $ ValueExp pv  -- | Like 'simplifyPrimExp', but where leaves may be 'Ext's.-simplifyExtPrimExp :: SimplifiableLore lore =>-                      PrimExp (Ext VName) -> SimpleM lore (PrimExp (Ext VName))+simplifyExtPrimExp ::+  SimplifiableLore lore =>+  PrimExp (Ext VName) ->+  SimpleM lore (PrimExp (Ext VName)) simplifyExtPrimExp = simplifyAnyPrimExp onLeaf-  where onLeaf (Free v) pt = do-          se <- simplify $ Var v-          case se of-            Var v' -> return $ LeafExp (Free v') pt-            Constant pv -> return $ ValueExp pv-        onLeaf (Ext i) pt = return $ LeafExp (Ext i) pt+  where+    onLeaf (Free v) pt = do+      se <- simplify $ Var v+      case se of+        Var v' -> return $ LeafExp (Free v') pt+        Constant pv -> return $ ValueExp pv+    onLeaf (Ext i) pt = return $ LeafExp (Ext i) pt -simplifyAnyPrimExp :: SimplifiableLore lore =>-                      (a -> PrimType -> SimpleM lore (PrimExp a))-                   -> PrimExp a -> SimpleM lore (PrimExp a)+simplifyAnyPrimExp ::+  SimplifiableLore lore =>+  (a -> PrimType -> SimpleM lore (PrimExp a)) ->+  PrimExp a ->+  SimpleM lore (PrimExp a) simplifyAnyPrimExp f (LeafExp v pt) = f v pt simplifyAnyPrimExp _ (ValueExp pv) =   return $ ValueExp pv

@@ -1,18 +1,19 @@-{-# LANGUAGE GADTs #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+ -- | Facilities for changing the lore of some fragment, with no -- context.  We call this "rephrasing", for no deep reason. module Futhark.Analysis.Rephrase-       ( rephraseProg-       , rephraseFunDef-       , rephraseExp-       , rephraseBody-       , rephraseStm-       , rephraseLambda-       , rephrasePattern-       , rephrasePatElem-       , Rephraser (..)-       )+  ( rephraseProg,+    rephraseFunDef,+    rephraseExp,+    rephraseBody,+    rephraseStm,+    rephraseLambda,+    rephrasePattern,+    rephrasePatElem,+    Rephraser (..),+  ) where  import Futhark.IR@@ -22,23 +23,23 @@ -- monad, we can conveniently do rephrasing that might fail.  This is -- useful if you want to see if some IR in e.g. the @Kernels@ lore -- actually uses any @Kernels@-specific operations.-data Rephraser m from to-  = Rephraser { rephraseExpLore :: ExpDec from -> m (ExpDec to)-              , rephraseLetBoundLore :: LetDec from -> m (LetDec to)-              , rephraseFParamLore :: FParamInfo from -> m (FParamInfo to)-              , rephraseLParamLore :: LParamInfo from -> m (LParamInfo to)-              , rephraseBodyLore :: BodyDec from -> m (BodyDec to)-              , rephraseRetType :: RetType from -> m (RetType to)-              , rephraseBranchType :: BranchType from -> m (BranchType to)-              , rephraseOp :: Op from -> m (Op to)-              }+data Rephraser m from to = Rephraser+  { rephraseExpLore :: ExpDec from -> m (ExpDec to),+    rephraseLetBoundLore :: LetDec from -> m (LetDec to),+    rephraseFParamLore :: FParamInfo from -> m (FParamInfo to),+    rephraseLParamLore :: LParamInfo from -> m (LParamInfo to),+    rephraseBodyLore :: BodyDec from -> m (BodyDec to),+    rephraseRetType :: RetType from -> m (RetType to),+    rephraseBranchType :: BranchType from -> m (BranchType to),+    rephraseOp :: Op from -> m (Op to)+  }  -- | Rephrase an entire program. rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to) rephraseProg rephraser (Prog consts funs) =   Prog-  <$> mapM (rephraseStm rephraser) consts-  <*> mapM (rephraseFunDef rephraser) funs+    <$> mapM (rephraseStm rephraser) consts+    <*> mapM (rephraseFunDef rephraser) funs  -- | Rephrase a function definition. rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to)@@ -46,7 +47,7 @@   body' <- rephraseBody rephraser $ funDefBody fundec   params' <- mapM (rephraseParam $ rephraseFParamLore rephraser) $ funDefParams fundec   rettype' <- mapM (rephraseRetType rephraser) $ funDefRetType fundec-  return fundec { funDefBody = body', funDefParams = params', funDefRetType = rettype' }+  return fundec {funDefBody = body', funDefParams = params', funDefRetType = rettype'}  -- | Rephrase an expression. rephraseExp :: Monad m => Rephraser m from to -> Exp from -> m (Exp to)@@ -55,16 +56,17 @@ -- | Rephrase a statement. rephraseStm :: Monad m => Rephraser m from to -> Stm from -> m (Stm to) rephraseStm rephraser (Let pat (StmAux cs attrs dec) e) =-  Let <$>-  rephrasePattern (rephraseLetBoundLore rephraser) pat <*>-  (StmAux cs attrs <$> rephraseExpLore rephraser dec) <*>-  rephraseExp rephraser e+  Let+    <$> rephrasePattern (rephraseLetBoundLore rephraser) pat+    <*> (StmAux cs attrs <$> rephraseExpLore rephraser dec)+    <*> rephraseExp rephraser e  -- | Rephrase a pattern.-rephrasePattern :: Monad m =>-                   (from -> m to)-                -> PatternT from-                -> m (PatternT to)+rephrasePattern ::+  Monad m =>+  (from -> m to) ->+  PatternT from ->+  m (PatternT to) rephrasePattern = traverse  -- | Rephrase a pattern element.@@ -80,24 +82,25 @@ -- | Rephrase a body. rephraseBody :: Monad m => Rephraser m from to -> Body from -> m (Body to) rephraseBody rephraser (Body lore bnds res) =-  Body <$>-  rephraseBodyLore rephraser lore <*>-  (stmsFromList <$> mapM (rephraseStm rephraser) (stmsToList bnds)) <*>-  pure res+  Body+    <$> rephraseBodyLore rephraser lore+    <*> (stmsFromList <$> mapM (rephraseStm rephraser) (stmsToList bnds))+    <*> pure res  -- | Rephrase a lambda. rephraseLambda :: Monad m => Rephraser m from to -> Lambda from -> m (Lambda to) rephraseLambda rephraser lam = do   body' <- rephraseBody rephraser $ lambdaBody lam   params' <- mapM (rephraseParam $ rephraseLParamLore rephraser) $ lambdaParams lam-  return lam { lambdaBody = body', lambdaParams = params' }+  return lam {lambdaBody = body', lambdaParams = params'}  mapper :: Monad m => Rephraser m from to -> Mapper from to m-mapper rephraser = identityMapper {-    mapOnBody = const $ rephraseBody rephraser-  , mapOnRetType = rephraseRetType rephraser-  , mapOnBranchType = rephraseBranchType rephraser-  , mapOnFParam = rephraseParam (rephraseFParamLore rephraser)-  , mapOnLParam = rephraseParam (rephraseLParamLore rephraser)-  , mapOnOp = rephraseOp rephraser-  }+mapper rephraser =+  identityMapper+    { mapOnBody = const $ rephraseBody rephraser,+      mapOnRetType = rephraseRetType rephraser,+      mapOnBranchType = rephraseBranchType rephraser,+      mapOnFParam = rephraseParam (rephraseFParamLore rephraser),+      mapOnLParam = rephraseParam (rephraseLParamLore rephraser),+      mapOnOp = rephraseOp rephraser+    }

@@ -1,85 +1,87 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ module Futhark.Analysis.SymbolTable-  ( SymbolTable (bindings, loopDepth, availableAtClosestLoop, simplifyMemory)-  , empty-  , fromScope-  , toScope+  ( SymbolTable (bindings, loopDepth, availableAtClosestLoop, simplifyMemory),+    empty,+    fromScope,+    toScope,      -- * Entries-  , Entry-  , deepen-  , entryDepth-  , entryLetBoundDec-  , entryIsSize+    Entry,+    deepen,+    entryDepth,+    entryLetBoundDec,+    entryIsSize,      -- * Lookup-  , elem-  , lookup-  , lookupStm-  , lookupExp-  , lookupBasicOp-  , lookupType-  , lookupSubExp-  , lookupAliases-  , lookupLoopVar-  , available-  , consume-  , index-  , index'-  , Indexed(..)-  , indexedAddCerts-  , IndexOp(..)+    elem,+    lookup,+    lookupStm,+    lookupExp,+    lookupBasicOp,+    lookupType,+    lookupSubExp,+    lookupAliases,+    lookupLoopVar,+    lookupLoopParam,+    available,+    consume,+    index,+    index',+    Indexed (..),+    indexedAddCerts,+    IndexOp (..),      -- * Insertion-  , insertStm-  , insertStms-  , insertFParams-  , insertLParam-  , insertLoopVar+    insertStm,+    insertStms,+    insertFParams,+    insertLParam,+    insertLoopVar,+    insertLoopMerge,      -- * Misc-  , hideCertified+    hideCertified,   )-  where+where  import Control.Arrow ((&&&)) import Control.Monad-import Data.Ord-import Data.Maybe-import Data.List (foldl', elemIndex)+import Data.List (elemIndex, foldl') import qualified Data.Map.Strict as M--import Prelude hiding (elem, lookup)-+import Data.Maybe+import Data.Ord import Futhark.Analysis.PrimExp.Convert import Futhark.IR hiding (FParam, lookupType) import qualified Futhark.IR as AST- import qualified Futhark.IR.Prop.Aliases as Aliases+import Prelude hiding (elem, lookup) -data SymbolTable lore = SymbolTable {-    loopDepth :: Int-  , bindings :: M.Map VName (Entry lore)-  , availableAtClosestLoop :: Names-    -- ^ Which names are available just before the most enclosing+data SymbolTable lore = SymbolTable+  { loopDepth :: Int,+    bindings :: M.Map VName (Entry lore),+    -- | Which names are available just before the most enclosing     -- loop?-  , simplifyMemory :: Bool-    -- ^ We are in a situation where we should+    availableAtClosestLoop :: Names,+    -- | We are in a situation where we should     -- simplify/hoist/un-existentialise memory as much as possible -     -- typically, inside a kernel.+    simplifyMemory :: Bool   }  instance Semigroup (SymbolTable lore) where   table1 <> table2 =-    SymbolTable { loopDepth = max (loopDepth table1) (loopDepth table2)-                , bindings = bindings table1 <> bindings table2-                , availableAtClosestLoop = availableAtClosestLoop table1 <>-                                           availableAtClosestLoop table2-                , simplifyMemory = simplifyMemory table1 || simplifyMemory table2-                }+    SymbolTable+      { loopDepth = max (loopDepth table1) (loopDepth table2),+        bindings = bindings table1 <> bindings table2,+        availableAtClosestLoop =+          availableAtClosestLoop table1+            <> availableAtClosestLoop table2,+        simplifyMemory = simplifyMemory table1 || simplifyMemory table2+      }  instance Monoid (SymbolTable lore) where   mempty = empty@@ -89,95 +91,103 @@  fromScope :: ASTLore lore => Scope lore -> SymbolTable lore fromScope = M.foldlWithKey' insertFreeVar' empty-  where insertFreeVar' m k dec = insertFreeVar k dec m+  where+    insertFreeVar' m k dec = insertFreeVar k dec m  toScope :: SymbolTable lore -> Scope lore toScope = M.map entryInfo . bindings  deepen :: SymbolTable lore -> SymbolTable lore-deepen vtable = vtable { loopDepth = loopDepth vtable + 1,-                         availableAtClosestLoop = namesFromList $ M.keys $ bindings vtable-                       }+deepen vtable =+  vtable+    { loopDepth = loopDepth vtable + 1,+      availableAtClosestLoop = namesFromList $ M.keys $ bindings vtable+    }  -- | The result of indexing a delayed array.-data Indexed = Indexed Certificates (PrimExp VName)-               -- ^ A PrimExp based on the indexes (that is, without-               -- accessing any actual array).-             | IndexedArray Certificates VName [PrimExp VName]-               -- ^ The indexing corresponds to another (perhaps more-               -- advantageous) array.+data Indexed+  = -- | A PrimExp based on the indexes (that is, without+    -- accessing any actual array).+    Indexed Certificates (PrimExp VName)+  | -- | The indexing corresponds to another (perhaps more+    -- advantageous) array.+    IndexedArray Certificates VName [TPrimExp Int64 VName]  indexedAddCerts :: Certificates -> Indexed -> Indexed-indexedAddCerts cs1 (Indexed cs2 v) = Indexed (cs1<>cs2) v-indexedAddCerts cs1 (IndexedArray cs2 arr v) = IndexedArray (cs1<>cs2) arr v+indexedAddCerts cs1 (Indexed cs2 v) = Indexed (cs1 <> cs2) v+indexedAddCerts cs1 (IndexedArray cs2 arr v) = IndexedArray (cs1 <> cs2) arr v  instance FreeIn Indexed where   freeIn' (Indexed cs v) = freeIn' cs <> freeIn' v   freeIn' (IndexedArray cs arr v) = freeIn' cs <> freeIn' arr <> freeIn' v  -- | Indexing a delayed array if possible.-type IndexArray = [PrimExp VName] -> Maybe Indexed+type IndexArray = [TPrimExp Int64 VName] -> Maybe Indexed -data Entry lore =-  Entry { entryConsumed :: Bool-          -- ^ True if consumed.-        , entryDepth :: Int-        , entryIsSize :: Bool-          -- ^ True if this name has been used as an array size,-          -- implying that it is non-negative.-        , entryType :: EntryType lore-        }+data Entry lore = Entry+  { -- | True if consumed.+    entryConsumed :: Bool,+    entryDepth :: Int,+    -- | True if this name has been used as an array size,+    -- implying that it is non-negative.+    entryIsSize :: Bool,+    entryType :: EntryType lore+  } -data EntryType lore = LoopVar (LoopVarEntry lore)-                    | LetBound (LetBoundEntry lore)-                    | FParam (FParamEntry lore)-                    | LParam (LParamEntry lore)-                    | FreeVar (FreeVarEntry lore)+data EntryType lore+  = LoopVar (LoopVarEntry lore)+  | LetBound (LetBoundEntry lore)+  | FParam (FParamEntry lore)+  | LParam (LParamEntry lore)+  | FreeVar (FreeVarEntry lore) -data LoopVarEntry lore =-  LoopVarEntry { loopVarType     :: IntType-               , loopVarBound    :: SubExp-               }+data LoopVarEntry lore = LoopVarEntry+  { loopVarType :: IntType,+    loopVarBound :: SubExp+  } -data LetBoundEntry lore =-  LetBoundEntry { letBoundDec      :: LetDec lore-                , letBoundAliases  :: Names-                , letBoundStm      :: Stm lore-                , letBoundIndex    :: Int -> IndexArray-                -- ^ Index a delayed array, if possible.-                }+data LetBoundEntry lore = LetBoundEntry+  { letBoundDec :: LetDec lore,+    letBoundAliases :: Names,+    letBoundStm :: Stm lore,+    -- | Index a delayed array, if possible.+    letBoundIndex :: Int -> IndexArray+  } -data FParamEntry lore =-  FParamEntry { fparamDec      :: FParamInfo lore-              , fparamAliases  :: Names-              }+data FParamEntry lore = FParamEntry+  { fparamDec :: FParamInfo lore,+    fparamAliases :: Names,+    -- | If a loop parameter, the initial value and the eventual+    -- result.  The result need not be in scope in the symbol table.+    fparamMerge :: Maybe (SubExp, SubExp)+  } -data LParamEntry lore =-  LParamEntry { lparamDec      :: LParamInfo lore-              , lparamIndex    :: IndexArray-              }+data LParamEntry lore = LParamEntry+  { lparamDec :: LParamInfo lore,+    lparamIndex :: IndexArray+  } -data FreeVarEntry lore =-  FreeVarEntry { freeVarDec      :: NameInfo lore-               , freeVarIndex    :: VName -> IndexArray-                -- ^ Index a delayed array, if possible.-               }+data FreeVarEntry lore = FreeVarEntry+  { freeVarDec :: NameInfo lore,+    -- | Index a delayed array, if possible.+    freeVarIndex :: VName -> IndexArray+  }  instance ASTLore lore => Typed (Entry lore) where   typeOf = typeOf . entryInfo  entryInfo :: Entry lore -> NameInfo lore entryInfo e = case entryType e of-                LetBound entry -> LetName $ letBoundDec entry-                LoopVar entry -> IndexName $ loopVarType entry-                FParam entry -> FParamName $ fparamDec entry-                LParam entry -> LParamName $ lparamDec entry-                FreeVar entry -> freeVarDec entry+  LetBound entry -> LetName $ letBoundDec entry+  LoopVar entry -> IndexName $ loopVarType entry+  FParam entry -> FParamName $ fparamDec entry+  LParam entry -> LParamName $ lparamDec entry+  FreeVar entry -> freeVarDec entry  isLetBound :: Entry lore -> Maybe (LetBoundEntry lore) isLetBound e = case entryType e of-                 LetBound entry -> Just entry-                 _ -> Nothing+  LetBound entry -> Just entry+  _ -> Nothing  entryStm :: Entry lore -> Maybe (Stm lore) entryStm = fmap letBoundStm . isLetBound@@ -200,7 +210,7 @@ lookupBasicOp :: VName -> SymbolTable lore -> Maybe (BasicOp, Certificates) lookupBasicOp name vtable = case lookupExp name vtable of   Just (BasicOp e, cs) -> Just (e, cs)-  _                    -> Nothing+  _ -> Nothing  lookupType :: ASTLore lore => VName -> SymbolTable lore -> Maybe Type lookupType name vtable = typeOf <$> lookup name vtable@@ -211,17 +221,17 @@  lookupSubExp :: VName -> SymbolTable lore -> Maybe (SubExp, Certificates) lookupSubExp name vtable = do-  (e,cs) <- lookupExp name vtable+  (e, cs) <- lookupExp name vtable   case e of-    BasicOp (SubExp se) -> Just (se,cs)-    _                   -> Nothing+    BasicOp (SubExp se) -> Just (se, cs)+    _ -> Nothing  lookupAliases :: VName -> SymbolTable lore -> Names lookupAliases name vtable =   case entryType <$> M.lookup name (bindings vtable) of     Just (LetBound e) -> letBoundAliases e-    Just (FParam e)   -> fparamAliases e-    _                 -> mempty+    Just (FParam e) -> fparamAliases e+    _ -> mempty  -- | If the given variable name is the name of a 'ForLoop' parameter, -- then return the bound of that loop.@@ -230,27 +240,42 @@   LoopVar e <- entryType <$> M.lookup name (bindings vtable)   return $ loopVarBound e +lookupLoopParam :: VName -> SymbolTable lore -> Maybe (SubExp, SubExp)+lookupLoopParam name vtable = do+  FParam e <- entryType <$> M.lookup name (bindings vtable)+  fparamMerge e+ -- | In symbol table and not consumed. available :: VName -> SymbolTable lore -> Bool available name = maybe False (not . entryConsumed) . M.lookup name . bindings -index :: ASTLore lore => VName -> [SubExp] -> SymbolTable lore-      -> Maybe Indexed+index ::+  ASTLore lore =>+  VName ->+  [SubExp] ->+  SymbolTable lore ->+  Maybe Indexed index name is table = do   is' <- mapM asPrimExp is   index' name is' table-  where asPrimExp i = do-          Prim t <- lookupSubExpType i table-          return $ primExpFromSubExp t i+  where+    asPrimExp i = do+      Prim t <- lookupSubExpType i table+      return $ TPrimExp $ primExpFromSubExp t i -index' :: VName -> [PrimExp VName] -> SymbolTable lore-       -> Maybe Indexed+index' ::+  VName ->+  [TPrimExp Int64 VName] ->+  SymbolTable lore ->+  Maybe Indexed index' name is vtable = do   entry <- lookup name vtable   case entryType entry of-    LetBound entry' |-      Just k <- elemIndex name $ patternValueNames $-                stmPattern $ letBoundStm entry' ->+    LetBound entry'+      | Just k <-+          elemIndex name $+            patternValueNames $+              stmPattern $ letBoundStm entry' ->         letBoundIndex entry' k is     FreeVar entry' ->       freeVarIndex entry' name is@@ -258,73 +283,83 @@     _ -> Nothing  class IndexOp op where-  indexOp :: (ASTLore lore, IndexOp (Op lore)) =>-             SymbolTable lore -> Int -> op-          -> [PrimExp VName] -> Maybe Indexed+  indexOp ::+    (ASTLore lore, IndexOp (Op lore)) =>+    SymbolTable lore ->+    Int ->+    op ->+    [TPrimExp Int64 VName] ->+    Maybe Indexed   indexOp _ _ _ _ = Nothing -instance IndexOp () where--indexExp :: (IndexOp (Op lore), ASTLore lore) =>-            SymbolTable lore -> Exp lore -> Int -> IndexArray+instance IndexOp () +indexExp ::+  (IndexOp (Op lore), ASTLore lore) =>+  SymbolTable lore ->+  Exp lore ->+  Int ->+  IndexArray indexExp vtable (Op op) k is =   indexOp vtable k op is- indexExp _ (BasicOp (Iota _ x s to_it)) _ [i] =-  Just $ Indexed mempty $-  sExt to_it i-  * primExpFromSubExp (IntType to_it) s-  + primExpFromSubExp (IntType to_it) x-+  Just $+    Indexed mempty $+      ( sExt to_it (untyped i)+          `mul` primExpFromSubExp (IntType to_it) s+      )+        `add` primExpFromSubExp (IntType to_it) x+  where+    mul = BinOpExp (Mul to_it OverflowWrap)+    add = BinOpExp (Add to_it OverflowWrap) indexExp table (BasicOp (Replicate (Shape ds) v)) _ is   | length ds == length is,     Just (Prim t) <- lookupSubExpType v table =-      Just $ Indexed mempty $ primExpFromSubExp t v--indexExp table (BasicOp (Replicate (Shape [_]) (Var v))) _ (_:is) =+    Just $ Indexed mempty $ primExpFromSubExp t v+indexExp table (BasicOp (Replicate (Shape [_]) (Var v))) _ (_ : is) =   index' v is table- indexExp table (BasicOp (Reshape newshape v)) _ is   | Just oldshape <- arrayDims <$> lookupType v table =-      let is' =-            reshapeIndex (map (primExpFromSubExp int32) oldshape)-                         (map (primExpFromSubExp int32) $ newDims newshape)-                         is-      in index' v is' table-+    let is' =+          reshapeIndex+            (map pe64 oldshape)+            (map pe64 $ newDims newshape)+            is+     in index' v is' table indexExp table (BasicOp (Index v slice)) _ is =   index' v (adjust slice is) table-  where adjust (DimFix j:js') is' =-          pe j : adjust js' is'-        adjust (DimSlice j _ s:js') (i:is') =-          let i_t_s = i * pe s-              j_p_i_t_s = pe j + i_t_s-          in j_p_i_t_s : adjust js' is'-        adjust _ _ = []--        pe = primExpFromSubExp (IntType Int32)-+  where+    adjust (DimFix j : js') is' =+      pe64 j : adjust js' is'+    adjust (DimSlice j _ s : js') (i : is') =+      let i_t_s = i * pe64 s+          j_p_i_t_s = pe64 j + i_t_s+       in j_p_i_t_s : adjust js' is'+    adjust _ _ = [] indexExp _ _ _ _ = Nothing -defBndEntry :: (ASTLore lore, IndexOp (Op lore)) =>-               SymbolTable lore-            -> PatElem lore-            -> Names-            -> Stm lore-            -> LetBoundEntry lore+defBndEntry ::+  (ASTLore lore, IndexOp (Op lore)) =>+  SymbolTable lore ->+  PatElem lore ->+  Names ->+  Stm lore ->+  LetBoundEntry lore defBndEntry vtable patElem als bnd =-  LetBoundEntry {-      letBoundDec = patElemDec patElem-    , letBoundAliases = als-    , letBoundStm = bnd-    , letBoundIndex = \k -> fmap (indexedAddCerts (stmAuxCerts $ stmAux bnd)) .-                            indexExp vtable (stmExp bnd) k+  LetBoundEntry+    { letBoundDec = patElemDec patElem,+      letBoundAliases = als,+      letBoundStm = bnd,+      letBoundIndex = \k ->+        fmap (indexedAddCerts (stmAuxCerts $ stmAux bnd))+          . indexExp vtable (stmExp bnd) k     } -bindingEntries :: (ASTLore lore, Aliases.Aliased lore, IndexOp (Op lore)) =>-                  Stm lore -> SymbolTable lore-               -> [LetBoundEntry lore]+bindingEntries ::+  (ASTLore lore, Aliases.Aliased lore, IndexOp (Op lore)) =>+  Stm lore ->+  SymbolTable lore ->+  [LetBoundEntry lore] bindingEntries bnd@(Let pat _ _) vtable = do   pat_elem <- patternElements pat   return $ defBndEntry vtable pat_elem (Aliases.aliasesOf pat_elem) bnd@@ -332,111 +367,186 @@ adjustSeveral :: Ord k => (v -> v) -> [k] -> M.Map k v -> M.Map k v adjustSeveral f = flip $ foldl' $ flip $ M.adjust f -insertEntry :: ASTLore lore =>-               VName -> EntryType lore -> SymbolTable lore-            -> SymbolTable lore+insertEntry ::+  ASTLore lore =>+  VName ->+  EntryType lore ->+  SymbolTable lore ->+  SymbolTable lore insertEntry name entry vtable =-  let entry' = Entry { entryConsumed = False-                     , entryDepth = loopDepth vtable-                     , entryIsSize = False-                     , entryType = entry-                     }+  let entry' =+        Entry+          { entryConsumed = False,+            entryDepth = loopDepth vtable,+            entryIsSize = False,+            entryType = entry+          }       dims = mapMaybe subExpVar $ arrayDims $ typeOf entry'-      isSize e = e { entryIsSize = True }-  in vtable { bindings = adjustSeveral isSize dims $-                         M.insert name entry' $ bindings vtable }+      isSize e = e {entryIsSize = True}+   in vtable+        { bindings =+            adjustSeveral isSize dims $+              M.insert name entry' $ bindings vtable+        } -insertEntries :: ASTLore lore =>-                 [(VName, EntryType lore)] -> SymbolTable lore-              -> SymbolTable lore+insertEntries ::+  ASTLore lore =>+  [(VName, EntryType lore)] ->+  SymbolTable lore ->+  SymbolTable lore insertEntries entries vtable =   foldl' add vtable entries-  where add vtable' (name, entry) = insertEntry name entry vtable'+  where+    add vtable' (name, entry) = insertEntry name entry vtable' -insertStm :: (ASTLore lore, IndexOp (Op lore), Aliases.Aliased lore) =>-             Stm lore-          -> SymbolTable lore-          -> SymbolTable lore+insertStm ::+  (ASTLore lore, IndexOp (Op lore), Aliases.Aliased lore) =>+  Stm lore ->+  SymbolTable lore ->+  SymbolTable lore insertStm stm vtable =   flip (foldl' $ flip consume) (namesToList stm_consumed) $-  flip (foldl' addRevAliases) (patternElements $ stmPattern stm) $-  insertEntries (zip names $ map LetBound $ bindingEntries stm vtable) vtable-  where names = patternNames $ stmPattern stm-        stm_consumed = expandAliases (Aliases.consumedInStm stm) vtable-        addRevAliases vtable' pe =-          vtable' { bindings = adjustSeveral update inedges $ bindings vtable' }-          where inedges = namesToList $ expandAliases (Aliases.aliasesOf pe) vtable'-                update e = e { entryType = update' $ entryType e }-                update' (LetBound entry) =-                  LetBound entry-                  { letBoundAliases = oneName (patElemName pe) <> letBoundAliases entry }-                update' (FParam entry) =-                  FParam entry-                  { fparamAliases = oneName (patElemName pe) <> fparamAliases entry }-                update' e = e+    flip (foldl' addRevAliases) (patternElements $ stmPattern stm) $+      insertEntries (zip names $ map LetBound $ bindingEntries stm vtable) vtable+  where+    names = patternNames $ stmPattern stm+    stm_consumed = expandAliases (Aliases.consumedInStm stm) vtable+    addRevAliases vtable' pe =+      vtable' {bindings = adjustSeveral update inedges $ bindings vtable'}+      where+        inedges = namesToList $ expandAliases (Aliases.aliasesOf pe) vtable'+        update e = e {entryType = update' $ entryType e}+        update' (LetBound entry) =+          LetBound+            entry+              { letBoundAliases = oneName (patElemName pe) <> letBoundAliases entry+              }+        update' (FParam entry) =+          FParam+            entry+              { fparamAliases = oneName (patElemName pe) <> fparamAliases entry+              }+        update' e = e -insertStms :: (ASTLore lore, IndexOp (Op lore), Aliases.Aliased lore) =>-              Stms lore -> SymbolTable lore -> SymbolTable lore+insertStms ::+  (ASTLore lore, IndexOp (Op lore), Aliases.Aliased lore) =>+  Stms lore ->+  SymbolTable lore ->+  SymbolTable lore insertStms stms vtable = foldl' (flip insertStm) vtable $ stmsToList stms  expandAliases :: Names -> SymbolTable lore -> Names expandAliases names vtable = names <> aliasesOfAliases-  where aliasesOfAliases =-          mconcat . map (`lookupAliases` vtable) . namesToList $ names+  where+    aliasesOfAliases =+      mconcat . map (`lookupAliases` vtable) . namesToList $ names -insertFParam :: ASTLore lore =>-                AST.FParam lore -> SymbolTable lore -> SymbolTable lore+insertFParam ::+  ASTLore lore =>+  AST.FParam lore ->+  SymbolTable lore ->+  SymbolTable lore insertFParam fparam = insertEntry name entry-  where name = AST.paramName fparam-        entry = FParam FParamEntry { fparamDec = AST.paramDec fparam-                                   , fparamAliases = mempty-                                   }+  where+    name = AST.paramName fparam+    entry =+      FParam+        FParamEntry+          { fparamDec = AST.paramDec fparam,+            fparamAliases = mempty,+            fparamMerge = Nothing+          } -insertFParams :: ASTLore lore =>-                 [AST.FParam lore] -> SymbolTable lore -> SymbolTable lore+insertFParams ::+  ASTLore lore =>+  [AST.FParam lore] ->+  SymbolTable lore ->+  SymbolTable lore insertFParams fparams symtable = foldl' (flip insertFParam) symtable fparams  insertLParam :: ASTLore lore => LParam lore -> SymbolTable lore -> SymbolTable lore insertLParam param = insertEntry name bind-  where bind = LParam LParamEntry { lparamDec = AST.paramDec param-                                  , lparamIndex = const Nothing-                                  }-        name = AST.paramName param+  where+    bind =+      LParam+        LParamEntry+          { lparamDec = AST.paramDec param,+            lparamIndex = const Nothing+          }+    name = AST.paramName param +-- | Insert entries corresponding to the parameters of a loop (not+-- distinguishing contect and value part).  Apart from the parameter+-- itself, we also insert the initial value and the subexpression+-- providing the final value.  Note that the latter is likely not in+-- scope in the symbol at this point.  This is OK, and can still be+-- used to help some loop optimisations detect invariant loop+-- parameters.+insertLoopMerge ::+  ASTLore lore =>+  [(AST.FParam lore, SubExp, SubExp)] ->+  SymbolTable lore ->+  SymbolTable lore+insertLoopMerge = flip $ foldl' $ flip bind+  where+    bind (p, initial, res) =+      insertEntry (paramName p) $+        FParam+          FParamEntry+            { fparamDec = AST.paramDec p,+              fparamAliases = mempty,+              fparamMerge = Just (initial, res)+            }+ insertLoopVar :: ASTLore lore => VName -> IntType -> SubExp -> SymbolTable lore -> SymbolTable lore insertLoopVar name it bound = insertEntry name bind-  where bind = LoopVar LoopVarEntry {-            loopVarType = it-          , loopVarBound = bound+  where+    bind =+      LoopVar+        LoopVarEntry+          { loopVarType = it,+            loopVarBound = bound           }  insertFreeVar :: ASTLore lore => VName -> NameInfo lore -> SymbolTable lore -> SymbolTable lore insertFreeVar name dec = insertEntry name entry-  where entry = FreeVar FreeVarEntry {-            freeVarDec = dec-          , freeVarIndex  = \_ _ -> Nothing+  where+    entry =+      FreeVar+        FreeVarEntry+          { freeVarDec = dec,+            freeVarIndex = \_ _ -> Nothing           }  consume :: VName -> SymbolTable lore -> SymbolTable lore-consume consumee vtable = foldl' consume' vtable $ namesToList $-                          expandAliases (oneName consumee) vtable-  where consume' vtable' v =-          vtable' { bindings = M.adjust consume'' v $ bindings vtable' }-        consume'' e = e { entryConsumed = True }+consume consumee vtable =+  foldl' consume' vtable $+    namesToList $+      expandAliases (oneName consumee) vtable+  where+    consume' vtable' v =+      vtable' {bindings = M.adjust consume'' v $ bindings vtable'}+    consume'' e = e {entryConsumed = True}  -- | Hide definitions of those entries that satisfy some predicate. hideIf :: (Entry lore -> Bool) -> SymbolTable lore -> SymbolTable lore-hideIf hide vtable = vtable { bindings = M.map maybeHide $ bindings vtable }-  where maybeHide entry-          | hide entry = entry { entryType =-                                   FreeVar FreeVarEntry { freeVarDec = entryInfo entry-                                                        , freeVarIndex = \_ _ -> Nothing-                                                        }-                               }-          | otherwise = entry+hideIf hide vtable = vtable {bindings = M.map maybeHide $ bindings vtable}+  where+    maybeHide entry+      | hide entry =+        entry+          { entryType =+              FreeVar+                FreeVarEntry+                  { freeVarDec = entryInfo entry,+                    freeVarIndex = \_ _ -> Nothing+                  }+          }+      | otherwise = entry  -- | Hide these definitions, if they are protected by certificates in -- the set of names. hideCertified :: Names -> SymbolTable lore -> SymbolTable lore hideCertified to_hide = hideIf $ maybe False hide . entryStm-  where hide = any (`nameIn` to_hide) . unCertificates . stmCerts+  where+    hide = any (`nameIn` to_hide) . unCertificates . stmCerts

@@ -1,40 +1,39 @@ {-# LANGUAGE Strict #-}+ -- | A usage-table is sort of a bottom-up symbol table, describing how -- (and if) a variable is used. module Futhark.Analysis.UsageTable-  ( UsageTable-  , without-  , lookup-  , used-  , expand-  , isConsumed-  , isInResult-  , isUsedDirectly-  , isSize-  , usages-  , usage-  , consumedUsage-  , inResultUsage-  , sizeUsage-  , sizeUsages-  , Usages-  , usageInStm+  ( UsageTable,+    without,+    lookup,+    used,+    expand,+    isConsumed,+    isInResult,+    isUsedDirectly,+    isSize,+    usages,+    usage,+    consumedUsage,+    inResultUsage,+    sizeUsage,+    sizeUsages,+    Usages,+    usageInStm,   )-  where+where  import Data.Bits import qualified Data.Foldable as Foldable import qualified Data.IntMap.Strict as IM import Data.List (foldl')--import Prelude hiding (lookup)- import Futhark.IR import Futhark.IR.Prop.Aliases+import Prelude hiding (lookup)  -- | A usage table. newtype UsageTable = UsageTable (IM.IntMap Usages)-                   deriving (Eq, Show)+  deriving (Eq, Show)  instance Semigroup UsageTable where   UsageTable table1 <> UsageTable table2 =@@ -62,9 +61,11 @@ -- | Expand the usage table based on aliasing information. expand :: (VName -> Names) -> UsageTable -> UsageTable expand look (UsageTable m) = UsageTable $ foldl' grow m $ IM.toList m-  where grow m' (k, v) = foldl' (grow'' $ v `withoutU` presentU) m' $-                         namesIntMap $ look $ VName (nameFromString "") k-        grow'' v m'' k = IM.insertWith (<>) (baseTag k) v m''+  where+    grow m' (k, v) =+      foldl' (grow'' $ v `withoutU` presentU) m' $+        namesIntMap $ look $ VName (nameFromString "") k+    grow'' v m'' k = IM.insertWith (<>) (baseTag k) v m''  is :: Usages -> VName -> UsageTable -> Bool is = lookupPred . matches@@ -144,30 +145,43 @@ -- a single statement. usageInStm :: (ASTLore lore, Aliased lore) => Stm lore -> UsageTable usageInStm (Let pat lore e) =-  mconcat [usageInPat,-           usageInExpLore,-           usageInExp e,-           usages (freeIn e)]-  where usageInPat =-          usages (mconcat (map freeIn $ patternElements pat)-                  `namesSubtract`-                  namesFromList (patternNames pat)) <>-          sizeUsages (foldMap (freeIn . patElemType) (patternElements pat))-        usageInExpLore =-          usages $ freeIn lore+  mconcat+    [ usageInPat,+      usageInExpLore,+      usageInExp e,+      usages (freeIn e)+    ]+  where+    usageInPat =+      usages+        ( mconcat (map freeIn $ patternElements pat)+            `namesSubtract` namesFromList (patternNames pat)+        )+        <> sizeUsages (foldMap (freeIn . patElemType) (patternElements pat))+    usageInExpLore =+      usages $ freeIn lore  usageInExp :: Aliased lore => Exp lore -> UsageTable usageInExp (Apply _ args _ _) =-  mconcat [ mconcat $ map consumedUsage $-            namesToList $ subExpAliases arg-          | (arg,d) <- args, d == Consume ]+  mconcat+    [ mconcat $+        map consumedUsage $+          namesToList $ subExpAliases arg+      | (arg, d) <- args,+        d == Consume+    ] usageInExp (DoLoop _ merge _ _) =-  mconcat [ mconcat $ map consumedUsage $-            namesToList $ subExpAliases se-          | (v,se) <- merge, unique $ paramDeclType v ]+  mconcat+    [ mconcat $+        map consumedUsage $+          namesToList $ subExpAliases se+      | (v, se) <- merge,+        unique $ paramDeclType v+    ] usageInExp (If _ tbranch fbranch _) =-  foldMap consumedUsage $ namesToList $-  consumedInBody tbranch <> consumedInBody fbranch+  foldMap consumedUsage $+    namesToList $+      consumedInBody tbranch <> consumedInBody fbranch usageInExp (BasicOp (Update src _ _)) =   consumedUsage src usageInExp (Op op) =

@@ -1,61 +1,59 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+ -- | Facilities for handling Futhark benchmark results.  A Futhark -- benchmark program is just like a Futhark test program. module Futhark.Bench-  ( RunResult (..)-  , DataResult(..)-  , BenchResult(..)-  , encodeBenchResults-  , decodeBenchResults--  , binaryName--  , benchmarkDataset-  , RunOptions(..)--  , prepareBenchmarkProgram-  , CompileOptions(..)+  ( RunResult (..),+    DataResult (..),+    BenchResult (..),+    encodeBenchResults,+    decodeBenchResults,+    binaryName,+    benchmarkDataset,+    RunOptions (..),+    prepareBenchmarkProgram,+    CompileOptions (..),   )-  where+where  import Control.Applicative import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad.Except+import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.HashMap.Strict as HM-import qualified Data.Aeson as JSON import qualified Data.Text as T-import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T-import System.FilePath+import qualified Data.Text.IO as T+import Futhark.Test import System.Exit+import System.FilePath import System.IO import System.IO.Error import System.IO.Temp (withSystemTempFile) import System.Process.ByteString (readProcessWithExitCode) import System.Timeout (timeout) -import Futhark.Test- -- | The runtime of a single succesful run.-newtype RunResult = RunResult { runMicroseconds :: Int }-                  deriving (Eq, Show)+newtype RunResult = RunResult {runMicroseconds :: Int}+  deriving (Eq, Show)  -- | The results for a single named dataset is either an error -- message, or runtime measurements along the stderr that was -- produced. data DataResult = DataResult String (Either T.Text ([RunResult], T.Text))-                deriving (Eq, Show)+  deriving (Eq, Show)  -- | The results for all datasets for some benchmark program. data BenchResult = BenchResult FilePath [DataResult]-                 deriving (Eq, Show)+  deriving (Eq, Show) -newtype DataResults = DataResults { unDataResults :: [DataResult] }-newtype BenchResults = BenchResults { unBenchResults :: [BenchResult] }+newtype DataResults = DataResults {unDataResults :: [DataResult]} +newtype BenchResults = BenchResults {unBenchResults :: [BenchResult]}+ instance JSON.ToJSON RunResult where   toJSON = JSON.toJSON . runMicroseconds @@ -71,24 +69,29 @@ instance JSON.FromJSON DataResults where   parseJSON = JSON.withObject "datasets" $ \o ->     DataResults <$> mapM datasetResult (HM.toList o)-    where datasetResult (k, v) =-            DataResult (T.unpack k) <$>-            ((Right <$> success v) <|> (Left <$> JSON.parseJSON v))-          success = JSON.withObject "result" $ \o ->-            (,) <$> o JSON..: "runtimes" <*> o JSON..: "stderr"+    where+      datasetResult (k, v) =+        DataResult (T.unpack k)+          <$> ((Right <$> success v) <|> (Left <$> JSON.parseJSON v))+      success = JSON.withObject "result" $ \o ->+        (,) <$> o JSON..: "runtimes" <*> o JSON..: "stderr"  dataResultJSON :: DataResult -> (T.Text, JSON.Value) dataResultJSON (DataResult desc (Left err)) =   (T.pack desc, JSON.toJSON err) dataResultJSON (DataResult desc (Right (runtimes, progerr))) =-  (T.pack desc, JSON.object-                [("runtimes", JSON.toJSON $ map runMicroseconds runtimes),-                 ("stderr", JSON.toJSON progerr)])+  ( T.pack desc,+    JSON.object+      [ ("runtimes", JSON.toJSON $ map runMicroseconds runtimes),+        ("stderr", JSON.toJSON progerr)+      ]+  )  benchResultJSON :: BenchResult -> (T.Text, JSON.Value) benchResultJSON (BenchResult prog r) =-  (T.pack prog,-   JSON.Object $ HM.singleton "datasets" (JSON.toJSON $ DataResults r))+  ( T.pack prog,+    JSON.Object $ HM.singleton "datasets" (JSON.toJSON $ DataResults r)+  )  instance JSON.ToJSON BenchResults where   toJSON (BenchResults rs) =@@ -97,11 +100,12 @@ instance JSON.FromJSON BenchResults where   parseJSON = JSON.withObject "benchmarks" $ \o ->     BenchResults <$> mapM onBenchmark (HM.toList o)-    where onBenchmark (k, v) =-            BenchResult (T.unpack k) <$>-            JSON.withObject "benchmark" onBenchmark' v-          onBenchmark' o =-            fmap unDataResults . JSON.parseJSON =<< o JSON..: "datasets"+    where+      onBenchmark (k, v) =+        BenchResult (T.unpack k)+          <$> JSON.withObject "benchmark" onBenchmark' v+      onBenchmark' o =+        fmap unDataResults . JSON.parseJSON =<< o JSON..: "datasets"  -- | Transform benchmark results to a JSON bytestring. encodeBenchResults :: [BenchResult] -> LBS.ByteString@@ -116,18 +120,24 @@ readRuntime :: T.Text -> Maybe Int readRuntime s = case reads $ T.unpack s of   [(runtime, _)] -> Just runtime-  _              -> Nothing+  _ -> Nothing  didNotFail :: FilePath -> ExitCode -> T.Text -> ExceptT T.Text IO () didNotFail _ ExitSuccess _ =   return () didNotFail program (ExitFailure code) stderr_s =-  throwError $ T.pack $ program ++ " failed with error code " ++ show code ++-  " and output:\n" ++ T.unpack stderr_s+  throwError $+    T.pack $+      program ++ " failed with error code " ++ show code+        ++ " and output:\n"+        ++ T.unpack stderr_s -compareResult :: (MonadError T.Text m, MonadIO m) =>-                 FilePath -> (SBS.ByteString, [Value]) -> (SBS.ByteString, [Value])-              -> m ()+compareResult ::+  (MonadError T.Text m, MonadIO m) =>+  FilePath ->+  (SBS.ByteString, [Value]) ->+  (SBS.ByteString, [Value]) ->+  m () compareResult program (expected_bs, expected_vs) (actual_bs, actual_vs) =   case compareValues1 actual_vs expected_vs of     Just mismatch -> do@@ -135,165 +145,194 @@           expectedf = program `replaceExtension` "expected"       liftIO $ SBS.writeFile actualf actual_bs       liftIO $ SBS.writeFile expectedf expected_bs-      throwError $ T.pack actualf <> " and " <> T.pack expectedf <>-        " do not match:\n" <> T.pack (show mismatch)+      throwError $+        T.pack actualf <> " and " <> T.pack expectedf+          <> " do not match:\n"+          <> T.pack (show mismatch)     Nothing ->       return () -runResult :: (MonadError T.Text m, MonadIO m) =>-             FilePath-          -> ExitCode-          -> SBS.ByteString-          -> SBS.ByteString-          -> m (SBS.ByteString, [Value])+runResult ::+  (MonadError T.Text m, MonadIO m) =>+  FilePath ->+  ExitCode ->+  SBS.ByteString ->+  SBS.ByteString ->+  m (SBS.ByteString, [Value]) runResult program ExitSuccess stdout_s _ =   case valuesFromByteString "stdout" $ LBS.fromStrict stdout_s of-    Left e   -> do+    Left e -> do       let actualf = program `replaceExtension` "actual"       liftIO $ SBS.writeFile actualf stdout_s       throwError $ T.pack $ show e <> "\n(See " <> actualf <> ")"     Right vs -> return (stdout_s, vs) runResult program (ExitFailure code) _ stderr_s =-  throwError $ T.pack $ binaryName program ++ " failed with error code " ++ show code ++-  " and output:\n" ++ T.unpack (T.decodeUtf8 stderr_s)+  throwError $+    T.pack $+      binaryName program ++ " failed with error code " ++ show code+        ++ " and output:\n"+        ++ T.unpack (T.decodeUtf8 stderr_s)  -- | How to run a benchmark.-data RunOptions =-  RunOptions-  { runRunner :: String-  , runRuns :: Int-  , runExtraOptions :: [String]-  , runTimeout :: Int-  , runVerbose :: Int-  , runResultAction :: Maybe (Int -> IO ())-    -- ^ Invoked for every runtime measured during the run.  Can be+data RunOptions = RunOptions+  { runRunner :: String,+    runRuns :: Int,+    runExtraOptions :: [String],+    runTimeout :: Int,+    runVerbose :: Int,+    -- | Invoked for every runtime measured during the run.  Can be     -- used to provide a progress bar.+    runResultAction :: Maybe (Int -> IO ())   } - -- | Like @tail -f@, but running an arbitrary IO action per line. follow :: (String -> IO ()) -> FilePath -> IO () follow f fname = go 0-  where go i = do-          i' <- withFile fname ReadMode $ \h -> do-            hSeek h AbsoluteSeek i-            goH h i-          go i'+  where+    go i = do+      i' <- withFile fname ReadMode $ \h -> do+        hSeek h AbsoluteSeek i+        goH h i+      go i' -        goH h i = do-          res <- tryIOError $ hGetLine h-          case res of-            Left e | isEOFError e -> do-                       threadDelay followDelayMicroseconds-                       pure i-                   | otherwise -> ioError e-            Right l -> do f l-                          goH h =<< hTell h+    goH h i = do+      res <- tryIOError $ hGetLine h+      case res of+        Left e+          | isEOFError e -> do+            threadDelay followDelayMicroseconds+            pure i+          | otherwise -> ioError e+        Right l -> do+          f l+          goH h =<< hTell h -        triesPerSecond = 10-        followDelayMicroseconds = 1000000 `div` triesPerSecond+    triesPerSecond = 10+    followDelayMicroseconds = 1000000 `div` triesPerSecond  -- | Run the benchmark program on the indicated dataset.-benchmarkDataset :: RunOptions -> FilePath -> T.Text-                 -> Values -> Maybe Success -> FilePath-                 -> IO (Either T.Text ([RunResult], T.Text))+benchmarkDataset ::+  RunOptions ->+  FilePath ->+  T.Text ->+  Values ->+  Maybe Success ->+  FilePath ->+  IO (Either T.Text ([RunResult], T.Text)) benchmarkDataset opts program entry input_spec expected_spec ref_out =   -- We store the runtime in a temporary file.   withSystemTempFile "futhark-bench" $ \tmpfile h -> do-  hClose h -- We will be writing and reading this ourselves.-  input <- getValuesBS dir input_spec-  let getValuesAndBS (SuccessValues vs) = do-        vs' <- getValues dir vs-        bs <- getValuesBS dir vs-        return (LBS.toStrict bs, vs')-      getValuesAndBS SuccessGenerateValues =-        getValuesAndBS $ SuccessValues $ InFile ref_out-  maybe_expected <- maybe (return Nothing) (fmap Just . getValuesAndBS) expected_spec-  let options = runExtraOptions opts ++ ["-e", T.unpack entry,-                                         "-t", tmpfile,-                                         "-r", show $ runRuns opts,-                                         "-b"]+    hClose h -- We will be writing and reading this ourselves.+    input <- getValuesBS dir input_spec+    let getValuesAndBS (SuccessValues vs) = do+          vs' <- getValues dir vs+          bs <- getValuesBS dir vs+          return (LBS.toStrict bs, vs')+        getValuesAndBS SuccessGenerateValues =+          getValuesAndBS $ SuccessValues $ InFile ref_out+    maybe_expected <- maybe (return Nothing) (fmap Just . getValuesAndBS) expected_spec+    let options =+          runExtraOptions opts+            ++ [ "-e",+                 T.unpack entry,+                 "-t",+                 tmpfile,+                 "-r",+                 show $ runRuns opts,+                 "-b"+               ] -  -- Explicitly prefixing the current directory is necessary for-  -- readProcessWithExitCode to find the binary when binOutputf has-  -- no program component.-  let (to_run, to_run_args)-        | null $ runRunner opts = ("." </> binaryName program, options)-        | otherwise = (runRunner opts, binaryName program : options)+    -- Explicitly prefixing the current directory is necessary for+    -- readProcessWithExitCode to find the binary when binOutputf has+    -- no program component.+    let (to_run, to_run_args)+          | null $ runRunner opts = ("." </> binaryName program, options)+          | otherwise = (runRunner opts, binaryName program : options) -  when (runVerbose opts > 1) $-    putStrLn $ unwords ["Running executable", show to_run,-                        "with arguments", show to_run_args]+    when (runVerbose opts > 1) $+      putStrLn $+        unwords+          [ "Running executable",+            show to_run,+            "with arguments",+            show to_run_args+          ] -  let onResult l-        | Just f <- runResultAction opts,-          [(x, "")] <- reads l =+    let onResult l+          | Just f <- runResultAction opts,+            [(x, "")] <- reads l =             f x-        | otherwise =+          | otherwise =             pure ()-  watcher <- forkIO $ follow onResult tmpfile--  run_res <--    timeout (runTimeout opts * 1000000) $-    readProcessWithExitCode to_run to_run_args $-    LBS.toStrict input+    watcher <- forkIO $ follow onResult tmpfile -  killThread watcher+    run_res <-+      timeout (runTimeout opts * 1000000) $+        readProcessWithExitCode to_run to_run_args $+          LBS.toStrict input -  runExceptT $ case run_res of-    Just (progCode, output, progerr) -> do-      case maybe_expected of-        Nothing ->-          didNotFail program progCode $ T.decodeUtf8 progerr-        Just expected ->-          compareResult program expected =<<-          runResult program progCode output progerr-      runtime_result <- liftIO $ T.readFile tmpfile-      runtimes <- case mapM readRuntime $ T.lines runtime_result of-        Just runtimes -> return $ map RunResult runtimes-        Nothing -> throwError $ "Runtime file has invalid contents:\n" <> runtime_result+    killThread watcher -      return (runtimes, T.decodeUtf8 progerr)-    Nothing ->-      throwError $ T.pack $ "Execution exceeded " ++ show (runTimeout opts) ++ " seconds."+    runExceptT $ case run_res of+      Just (progCode, output, progerr) -> do+        case maybe_expected of+          Nothing ->+            didNotFail program progCode $ T.decodeUtf8 progerr+          Just expected ->+            compareResult program expected+              =<< runResult program progCode output progerr+        runtime_result <- liftIO $ T.readFile tmpfile+        runtimes <- case mapM readRuntime $ T.lines runtime_result of+          Just runtimes -> return $ map RunResult runtimes+          Nothing -> throwError $ "Runtime file has invalid contents:\n" <> runtime_result -  where dir = takeDirectory program+        return (runtimes, T.decodeUtf8 progerr)+      Nothing ->+        throwError $ T.pack $ "Execution exceeded " ++ show (runTimeout opts) ++ " seconds."+  where+    dir = takeDirectory program  -- | How to compile a benchmark.-data CompileOptions =-  CompileOptions-  { compFuthark :: String-  , compBackend :: String-  , compOptions :: [String]+data CompileOptions = CompileOptions+  { compFuthark :: String,+    compBackend :: String,+    compOptions :: [String]   }  progNotFound :: String -> String progNotFound s = s ++ ": command not found"  -- | Compile and produce reference datasets.-prepareBenchmarkProgram :: MonadIO m =>-                           Maybe Int-                        -> CompileOptions-                        -> FilePath-                        -> [InputOutputs]-                        -> m (Either (String, Maybe SBS.ByteString) ())+prepareBenchmarkProgram ::+  MonadIO m =>+  Maybe Int ->+  CompileOptions ->+  FilePath ->+  [InputOutputs] ->+  m (Either (String, Maybe SBS.ByteString) ()) prepareBenchmarkProgram concurrency opts program cases = do   let futhark = compFuthark opts    ref_res <- runExceptT $ ensureReferenceOutput concurrency futhark "c" program cases   case ref_res of     Left err ->-      return $ Left ("Reference output generation for " ++ program ++ " failed:\n" ++-                     unlines (map T.unpack err),-                     Nothing)-+      return $+        Left+          ( "Reference output generation for " ++ program ++ " failed:\n"+              ++ unlines (map T.unpack err),+            Nothing+          )     Right () -> do-      (futcode, _, futerr) <- liftIO $ readProcessWithExitCode futhark-                              ([compBackend opts, program, "-o", binaryName program] <>-                               compOptions opts)-                              ""+      (futcode, _, futerr) <-+        liftIO $+          readProcessWithExitCode+            futhark+            ( [compBackend opts, program, "-o", binaryName program]+                <> compOptions opts+            )+            ""        case futcode of-        ExitSuccess     -> return $ Right ()+        ExitSuccess -> return $ Right ()         ExitFailure 127 -> return $ Left (progNotFound futhark, Nothing)-        ExitFailure _   -> return $ Left ("Compilation of " ++ program ++ " failed:\n", Just futerr)+        ExitFailure _ -> return $ Left ("Compilation of " ++ program ++ " failed:\n", Just futerr)

@@ -1,7 +1,13 @@-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | This module defines a convenience monad/typeclass for creating -- normalised programs.  The fundamental building block is 'BinderT' -- and its execution functions, but it is usually easier to use@@ -10,27 +16,28 @@ -- See "Futhark.Construct" for a high-level description. module Futhark.Binder   ( -- * A concrete @MonadBinder@ monad.-    BinderT-  , runBinderT, runBinderT_-  , runBinderT', runBinderT'_-  , BinderOps (..)-  , Binder-  , runBinder-  , runBinder_-  , runBodyBinder+    BinderT,+    runBinderT,+    runBinderT_,+    runBinderT',+    runBinderT'_,+    BinderOps (..),+    Binder,+    runBinder,+    runBinder_,+    runBodyBinder, -  -- * The 'MonadBinder' typeclass-  , module Futhark.Binder.Class+    -- * The 'MonadBinder' typeclass+    module Futhark.Binder.Class,   ) where  import Control.Arrow (second)-import Control.Monad.Writer-import Control.Monad.State.Strict-import Control.Monad.Reader import Control.Monad.Error.Class+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Writer import qualified Data.Map.Strict as M- import Futhark.Binder.Class import Futhark.IR @@ -38,23 +45,41 @@ -- 'MonadBinder' for lores that implement this type class, which -- contains methods for constructing statements. class ASTLore lore => BinderOps lore where-  mkExpDecB :: (MonadBinder m, Lore m ~ lore) =>-                Pattern lore -> Exp lore -> m (ExpDec lore)-  mkBodyB :: (MonadBinder m, Lore m ~ lore) =>-             Stms lore -> Result -> m (Body lore)-  mkLetNamesB :: (MonadBinder m, Lore m ~ lore) =>-                 [VName] -> Exp lore -> m (Stm lore)+  mkExpDecB ::+    (MonadBinder m, Lore m ~ lore) =>+    Pattern lore ->+    Exp lore ->+    m (ExpDec lore)+  mkBodyB ::+    (MonadBinder m, Lore m ~ lore) =>+    Stms lore ->+    Result ->+    m (Body lore)+  mkLetNamesB ::+    (MonadBinder m, Lore m ~ lore) =>+    [VName] ->+    Exp lore ->+    m (Stm lore) -  default mkExpDecB :: (MonadBinder m, Bindable lore) =>-                       Pattern lore -> Exp lore -> m (ExpDec lore)+  default mkExpDecB ::+    (MonadBinder m, Bindable lore) =>+    Pattern lore ->+    Exp lore ->+    m (ExpDec lore)   mkExpDecB pat e = return $ mkExpDec pat e -  default mkBodyB :: (MonadBinder m, Bindable lore) =>-                     Stms lore -> Result -> m (Body lore)+  default mkBodyB ::+    (MonadBinder m, Bindable lore) =>+    Stms lore ->+    Result ->+    m (Body lore)   mkBodyB stms res = return $ mkBody stms res -  default mkLetNamesB :: (MonadBinder m, Lore m ~ lore, Bindable lore) =>-                         [VName] -> Exp lore -> m (Stm lore)+  default mkLetNamesB ::+    (MonadBinder m, Lore m ~ lore, Bindable lore) =>+    [VName] ->+    Exp lore ->+    m (Stm lore)   mkLetNamesB = mkLetNames  -- | A monad transformer that tracks statements and provides a@@ -76,8 +101,10 @@   getNameSource = lift getNameSource   putNameSource = lift . putNameSource -instance (ASTLore lore, Monad m) =>-         HasScope lore (BinderT lore m) where+instance+  (ASTLore lore, Monad m) =>+  HasScope lore (BinderT lore m)+  where   lookupType name = do     t <- BinderT $ gets $ M.lookup name . snd     case t of@@ -85,24 +112,29 @@       Just t' -> return $ typeOf t'   askScope = BinderT $ gets snd -instance (ASTLore lore, Monad m) =>-         LocalScope lore (BinderT lore m) where+instance+  (ASTLore lore, Monad m) =>+  LocalScope lore (BinderT lore m)+  where   localScope types (BinderT m) = BinderT $ do     modify $ second (M.union types)     x <- m     modify $ second (`M.difference` types)     return x -instance (ASTLore lore, MonadFreshNames m, BinderOps lore) =>-         MonadBinder (BinderT lore m) where+instance+  (ASTLore lore, MonadFreshNames m, BinderOps lore) =>+  MonadBinder (BinderT lore m)+  where   type Lore (BinderT lore m) = lore   mkExpDecM = mkExpDecB   mkBodyM = mkBodyB   mkLetNamesM = mkLetNamesB    addStms stms =-    BinderT $ modify $ \(cur_stms,scope) ->-    (cur_stms<>stms, scope `M.union` scopeOf stms)+    BinderT $+      modify $ \(cur_stms, scope) ->+        (cur_stms <> stms, scope `M.union` scopeOf stms)    collectStms m = do     (old_stms, old_scope) <- BinderT get@@ -114,67 +146,88 @@  -- | Run a binder action given an initial scope, returning a value and -- the statements added ('addStm') during the action.-runBinderT :: MonadFreshNames m =>-              BinderT lore m a-           -> Scope lore-           -> m (a, Stms lore)+runBinderT ::+  MonadFreshNames m =>+  BinderT lore m a ->+  Scope lore ->+  m (a, Stms lore) runBinderT (BinderT m) scope = do   (x, (stms, _)) <- runStateT m (mempty, scope)   return (x, stms)  -- | Like 'runBinderT', but return only the statements.-runBinderT_ :: MonadFreshNames m =>-               BinderT lore m () -> Scope lore -> m (Stms lore)+runBinderT_ ::+  MonadFreshNames m =>+  BinderT lore m () ->+  Scope lore ->+  m (Stms lore) runBinderT_ m = fmap snd . runBinderT m  -- | Like 'runBinderT', but get the initial scope from the current -- monad.-runBinderT' :: (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) =>-               BinderT lore m a-            -> m (a, Stms lore)+runBinderT' ::+  (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) =>+  BinderT lore m a ->+  m (a, Stms lore) runBinderT' m = do   scope <- askScope   runBinderT m $ castScope scope  -- | Like 'runBinderT_', but get the initial scope from the current -- monad.-runBinderT'_ :: (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) =>-                BinderT lore m a -> m (Stms lore)+runBinderT'_ ::+  (MonadFreshNames m, HasScope somelore m, SameScope somelore lore) =>+  BinderT lore m a ->+  m (Stms lore) runBinderT'_ = fmap snd . runBinderT'  -- | Run a binder action, returning a value and the statements added -- ('addStm') during the action.  Assumes that the current monad -- provides initial scope and name source.-runBinder :: (MonadFreshNames m,-              HasScope somelore m, SameScope somelore lore) =>-              Binder lore a-           -> m (a, Stms lore)+runBinder ::+  ( MonadFreshNames m,+    HasScope somelore m,+    SameScope somelore lore+  ) =>+  Binder lore a ->+  m (a, Stms lore) runBinder m = do   types <- askScope   modifyNameSource $ runState $ runBinderT m $ castScope types  -- | Like 'runBinder', but throw away the result and just return the -- added statements.-runBinder_ :: (MonadFreshNames m,-               HasScope somelore m, SameScope somelore lore) =>-              Binder lore a-           -> m (Stms lore)+runBinder_ ::+  ( MonadFreshNames m,+    HasScope somelore m,+    SameScope somelore lore+  ) =>+  Binder lore a ->+  m (Stms lore) runBinder_ = fmap snd . runBinder  -- | Run a binder that produces a t'Body', and prefix that t'Body' by -- the statements produced during execution of the action.-runBodyBinder :: (Bindable lore, MonadFreshNames m,-                  HasScope somelore m, SameScope somelore lore) =>-                 Binder lore (Body lore) -> m (Body lore)+runBodyBinder ::+  ( Bindable lore,+    MonadFreshNames m,+    HasScope somelore m,+    SameScope somelore lore+  ) =>+  Binder lore (Body lore) ->+  m (Body lore) runBodyBinder = fmap (uncurry $ flip insertStms) . runBinder  -- Utility instance defintions for MTL classes.  These require -- UndecidableInstances, but save on typing elsewhere. -mapInner :: Monad m =>-            (m (a, (Stms lore, Scope lore))-             -> m (b, (Stms lore, Scope lore)))-         -> BinderT lore m a -> BinderT lore m b+mapInner ::+  Monad m =>+  ( m (a, (Stms lore, Scope lore)) ->+    m (b, (Stms lore, Scope lore))+  ) ->+  BinderT lore m a ->+  BinderT lore m b mapInner f (BinderT m) = BinderT $ do   s <- get   (x, s') <- lift $ f $ runStateT m s@@ -202,4 +255,5 @@   throwError = lift . throwError   catchError (BinderT m) f =     BinderT $ catchError m $ unBinder . f-    where unBinder (BinderT m') = m'+    where+      unBinder (BinderT m') = m'

@@ -1,28 +1,28 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ -- | This module defines a convenience typeclass for creating -- normalised programs. -- -- See "Futhark.Construct" for a high-level description. module Futhark.Binder.Class-  ( Bindable (..)-  , mkLet-  , mkLet'-  , MonadBinder (..)-  , insertStms-  , insertStm-  , letBind-  , letBindNames-  , collectStms_-  , bodyBind-  , attributing-  , auxing--  , module Futhark.MonadFreshNames+  ( Bindable (..),+    mkLet,+    mkLet',+    MonadBinder (..),+    insertStms,+    insertStm,+    letBind,+    letBindNames,+    collectStms_,+    bodyBind,+    attributing,+    auxing,+    module Futhark.MonadFreshNames,   ) where  import qualified Data.Kind- import Futhark.IR import Futhark.MonadFreshNames @@ -32,18 +32,24 @@ -- often than you think, and the results thrown away.  If used -- exclusively within a 'MonadBinder' instance, it is acceptable for -- them to create new bindings, however.-class (ASTLore lore,-       FParamInfo lore ~ DeclType,-       LParamInfo lore ~ Type,-       RetType lore ~ DeclExtType,-       BranchType lore ~ ExtType,-       SetType (LetDec lore)) =>-      Bindable lore where+class+  ( ASTLore lore,+    FParamInfo lore ~ DeclType,+    LParamInfo lore ~ Type,+    RetType lore ~ DeclExtType,+    BranchType lore ~ ExtType,+    SetType (LetDec lore)+  ) =>+  Bindable lore+  where   mkExpPat :: [Ident] -> [Ident] -> Exp lore -> Pattern lore   mkExpDec :: Pattern lore -> Exp lore -> ExpDec lore   mkBody :: Stms lore -> Result -> Body lore-  mkLetNames :: (MonadFreshNames m, HasScope lore m) =>-                [VName] -> Exp lore -> m (Stm lore)+  mkLetNames ::+    (MonadFreshNames m, HasScope lore m) =>+    [VName] ->+    Exp lore ->+    m (Stm lore)  -- | A monad that supports the creation of bindings from expressions -- and bodies from bindings, with a specific lore.  This is the main@@ -56,21 +62,26 @@ -- effects!  They may be called more often than you think, and the -- results thrown away.  It is acceptable for them to create new -- bindings, however.-class (ASTLore (Lore m),-       MonadFreshNames m, Applicative m, Monad m,-       LocalScope (Lore m) m) =>-      MonadBinder m where+class+  ( ASTLore (Lore m),+    MonadFreshNames m,+    Applicative m,+    Monad m,+    LocalScope (Lore m) m+  ) =>+  MonadBinder m+  where   type Lore m :: Data.Kind.Type   mkExpDecM :: Pattern (Lore m) -> Exp (Lore m) -> m (ExpDec (Lore m))   mkBodyM :: Stms (Lore m) -> Result -> m (Body (Lore m))   mkLetNamesM :: [VName] -> Exp (Lore m) -> m (Stm (Lore m))    -- | Add a statement to the 'Stms' under construction.-  addStm      :: Stm (Lore m) -> m ()-  addStm      = addStms . oneStm+  addStm :: Stm (Lore m) -> m ()+  addStm = addStms . oneStm    -- | Add multiple statements to the 'Stms' under construction.-  addStms     :: Stms (Lore m) -> m ()+  addStms :: Stms (Lore m) -> m ()    -- | Obtain the statements constructed during a monadic action,   -- instead of adding them to the state.@@ -82,9 +93,11 @@   certifying = censorStms . fmap . certify  -- | Apply a function to the statements added by this action.-censorStms :: MonadBinder m =>-              (Stms (Lore m) -> Stms (Lore m))-           -> m a -> m a+censorStms ::+  MonadBinder m =>+  (Stms (Lore m) -> Stms (Lore m)) ->+  m a ->+  m a censorStms f m = do   (x, stms) <- collectStms m   addStms $ f stms@@ -93,22 +106,30 @@ -- | Add the given attributes to any statements added by this action. attributing :: MonadBinder m => Attrs -> m a -> m a attributing attrs = censorStms $ fmap onStm-  where onStm (Let pat aux e) =-          Let pat aux { stmAuxAttrs = attrs <> stmAuxAttrs aux } e+  where+    onStm (Let pat aux e) =+      Let pat aux {stmAuxAttrs = attrs <> stmAuxAttrs aux} e  -- | Add the certificates and attributes to any statements added by -- this action. auxing :: MonadBinder m => StmAux anylore -> m a -> m a auxing (StmAux cs attrs _) = censorStms $ fmap onStm-  where onStm (Let pat aux e) =-          Let pat aux' e-          where aux' = aux { stmAuxAttrs = attrs <> stmAuxAttrs aux-                           , stmAuxCerts = cs <> stmAuxCerts aux-                           }+  where+    onStm (Let pat aux e) =+      Let pat aux' e+      where+        aux' =+          aux+            { stmAuxAttrs = attrs <> stmAuxAttrs aux,+              stmAuxCerts = cs <> stmAuxCerts aux+            }  -- | Add a statement with the given pattern and expression.-letBind :: MonadBinder m =>-            Pattern (Lore m) -> Exp (Lore m) -> m ()+letBind ::+  MonadBinder m =>+  Pattern (Lore m) ->+  Exp (Lore m) ->+  m () letBind pat e =   addStm =<< Let pat <$> (defAux <$> mkExpDecM pat e) <*> pure e @@ -118,7 +139,7 @@ mkLet ctx val e =   let pat = mkExpPat ctx val e       dec = mkExpDec pat e-  in Let pat (defAux dec) e+   in Let pat (defAux dec) e  -- | Like mkLet, but also take attributes and certificates from the -- given 'StmAux'.@@ -126,7 +147,7 @@ mkLet' ctx val (StmAux cs attrs _) e =   let pat = mkExpPat ctx val e       dec = mkExpDec pat e-  in Let pat (StmAux cs attrs dec) e+   in Let pat (StmAux cs attrs dec) e  -- | Add a statement with the given pattern element names and -- expression.@@ -145,7 +166,7 @@  -- | Add several bindings at the outermost level of a t'Body'. insertStms :: Bindable lore => Stms lore -> Body lore -> Body lore-insertStms stms1 (Body _ stms2 res) = mkBody (stms1<>stms2) res+insertStms stms1 (Body _ stms2 res) = mkBody (stms1 <> stms2) res  -- | Add a single binding at the outermost level of a t'Body'. insertStm :: Bindable lore => Stm lore -> Body lore -> Body lore

@@ -1,40 +1,39 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ -- | @futhark autotune@ module Futhark.CLI.Autotune (main) where  import Control.Monad import qualified Data.ByteString.Char8 as SBS import Data.Function (on)-import Data.Tree-import Data.List (intersect, isPrefixOf, sort, sortOn, elemIndex, minimumBy)+import Data.List (elemIndex, intersect, isPrefixOf, minimumBy, sort, sortOn) import Data.Maybe-import Text.Read (readMaybe)-import Text.Regex.TDFA-import qualified Data.Text as T import qualified Data.Set as S--import System.Environment (getExecutablePath)-import System.Exit-import System.Process-import System.FilePath-import System.Console.GetOpt-+import qualified Data.Text as T+import Data.Tree import Futhark.Bench import Futhark.Test import Futhark.Util (maxinum) import Futhark.Util.Options+import System.Console.GetOpt+import System.Environment (getExecutablePath)+import System.Exit+import System.FilePath+import System.Process+import Text.Read (readMaybe)+import Text.Regex.TDFA  data AutotuneOptions = AutotuneOptions-                    { optBackend :: String-                    , optFuthark :: Maybe String-                    , optRuns :: Int-                    , optTuning :: Maybe String-                    , optExtraOptions :: [String]-                    , optVerbose :: Int-                    , optTimeout :: Int-                    , optDefaultThreshold :: Int-                    }+  { optBackend :: String,+    optFuthark :: Maybe String,+    optRuns :: Int,+    optTuning :: Maybe String,+    optExtraOptions :: [String],+    optVerbose :: Int,+    optTimeout :: Int,+    optDefaultThreshold :: Int+  }  initialAutotuneOptions :: AutotuneOptions initialAutotuneOptions =@@ -43,25 +42,30 @@ compileOptions :: AutotuneOptions -> IO CompileOptions compileOptions opts = do   futhark <- maybe getExecutablePath return $ optFuthark opts-  return $ CompileOptions { compFuthark = futhark-                          , compBackend = optBackend opts-                          , compOptions = mempty-                          }+  return $+    CompileOptions+      { compFuthark = futhark,+        compBackend = optBackend opts,+        compOptions = mempty+      }  runOptions :: Path -> Int -> AutotuneOptions -> RunOptions runOptions path timeout_s opts =-  RunOptions { runRunner = ""-             , runRuns = optRuns opts-             , runExtraOptions = "--default-threshold" :-                                 show (optDefaultThreshold opts) :-                                 "-L" :-                                 map opt path ++-                                 optExtraOptions opts-             , runTimeout = timeout_s-             , runVerbose = optVerbose opts-             , runResultAction = Nothing-             }-  where opt (name, val) = "--size=" ++ name ++ "=" ++ show val+  RunOptions+    { runRunner = "",+      runRuns = optRuns opts,+      runExtraOptions =+        "--default-threshold" :+        show (optDefaultThreshold opts) :+        "-L" :+        map opt path+          ++ optExtraOptions opts,+      runTimeout = timeout_s,+      runVerbose = optVerbose opts,+      runResultAction = Nothing+    }+  where+    opt (name, val) = "--size=" ++ name ++ "=" ++ show val  type Path = [(String, Int)] @@ -71,13 +75,14 @@     matchM regex s :: Maybe (String, String, String, [String])   Just groups -comparisons :: String -> [(String,Int)]+comparisons :: String -> [(String, Int)] comparisons = mapMaybe isComparison . lines-  where regex = makeRegex ("Compared ([^ ]+) <= (-?[0-9]+)" :: String)-        isComparison l = do [thresh, val] <- regexGroups regex l-                            val' <- readMaybe val-                            return (thresh, val')-+  where+    regex = makeRegex ("Compared ([^ ]+) <= (-?[0-9]+)" :: String)+    isComparison l = do+      [thresh, val] <- regexGroups regex l+      val' <- readMaybe val+      return (thresh, val')  type RunDataset = Int -> Path -> IO (Either String ([(String, Int)], Int)) @@ -91,18 +96,18 @@   truns <-     case testAction spec of       RunCases ios _ _ | not $ null ios -> do-            when (optVerbose opts > 1) $-               putStrLn $-                 unwords ("Entry points:" : map (T.unpack . iosEntryPoint) ios)+        when (optVerbose opts > 1) $+          putStrLn $+            unwords ("Entry points:" : map (T.unpack . iosEntryPoint) ios) -            res <- prepareBenchmarkProgram Nothing copts prog ios-            case res of-              Left (err, errstr) -> do-                putStrLn err-                maybe (return ()) SBS.putStrLn errstr-                exitFailure-              Right () ->-                return ios+        res <- prepareBenchmarkProgram Nothing copts prog ios+        case res of+          Left (err, errstr) -> do+            putStrLn err+            maybe (return ()) SBS.putStrLn errstr+            exitFailure+          Right () ->+            return ios       _ ->         fail "Unsupported test spec." @@ -110,36 +115,44 @@         case runExpectedResult trun of           Succeeds expected             | null (runTags trun `intersect` ["notune", "disable"]) ->-                Just (runDescription trun, run entry_point trun expected)-+              Just (runDescription trun, run entry_point trun expected)           _ -> Nothing -  fmap concat $ forM truns $ \ios ->-    forM (mapMaybe (runnableDataset $ iosEntryPoint ios)-                   (iosTestRuns ios)) $-      \(dataset, do_run) ->-        return (dataset, do_run, iosEntryPoint ios)--  where run entry_point trun expected timeout path = do-          let bestRuntime :: ([RunResult], T.Text) -> ([(String, Int)], Int)-              bestRuntime (runres, errout) =-                (comparisons (T.unpack errout),-                 minimum $ map runMicroseconds runres)+  fmap concat $+    forM truns $ \ios ->+      forM+        ( mapMaybe+            (runnableDataset $ iosEntryPoint ios)+            (iosTestRuns ios)+        )+        $ \(dataset, do_run) ->+          return (dataset, do_run, iosEntryPoint ios)+  where+    run entry_point trun expected timeout path = do+      let bestRuntime :: ([RunResult], T.Text) -> ([(String, Int)], Int)+          bestRuntime (runres, errout) =+            ( comparisons (T.unpack errout),+              minimum $ map runMicroseconds runres+            ) -              ropts = runOptions path timeout opts+          ropts = runOptions path timeout opts -          when (optVerbose opts > 1) $-            putStrLn $ "Running with options: " ++ unwords (runExtraOptions ropts)+      when (optVerbose opts > 1) $+        putStrLn $ "Running with options: " ++ unwords (runExtraOptions ropts) -          either (Left . T.unpack) (Right . bestRuntime) <$>-            benchmarkDataset ropts prog entry_point-            (runInput trun) expected-            (testRunReferenceOutput prog entry_point trun)+      either (Left . T.unpack) (Right . bestRuntime)+        <$> benchmarkDataset+          ropts+          prog+          entry_point+          (runInput trun)+          expected+          (testRunReferenceOutput prog entry_point trun)  --- Benchmarking a program  data DatasetResult = DatasetResult [(String, Int)] Double-             deriving Show+  deriving (Show)  --- Finding initial comparisons. @@ -156,101 +169,120 @@ -- are used. tuningPaths :: ThresholdForest -> [(String, Path)] tuningPaths = concatMap (treePaths [])-  where treePaths ancestors (Node (v, _) children) =-          concatMap (onChild ancestors v) children ++ [(v, ancestors)]+  where+    treePaths ancestors (Node (v, _) children) =+      concatMap (onChild ancestors v) children ++ [(v, ancestors)] -        onChild ancestors v child@(Node (_, cmp) _) =-          treePaths (ancestors++[(v, t cmp)]) child+    onChild ancestors v child@(Node (_, cmp) _) =+      treePaths (ancestors ++ [(v, t cmp)]) child -        t False = thresholdMax-        t True = thresholdMin+    t False = thresholdMax+    t True = thresholdMin  thresholdForest :: FilePath -> IO ThresholdForest thresholdForest prog = do-  thresholds <- getThresholds <$>-    readProcess ("." </> dropExtension prog) ["--print-sizes"] ""+  thresholds <-+    getThresholds+      <$> readProcess ("." </> dropExtension prog) ["--print-sizes"] ""   let root (v, _) = ((v, False), [])-  return $ unfoldForest (unfold thresholds) $-    map root $ filter (null . snd) thresholds-  where getThresholds = mapMaybe findThreshold . lines-        regex = makeRegex ("(.*)\\ \\(threshold\\ \\((.*)\\)\\)" :: String)--        findThreshold :: String -> Maybe (String, [(String, Bool)])-        findThreshold l = do [grp1, grp2] <- regexGroups regex l-                             return (grp1,-                                     filter (not . null . fst) $-                                     map (\x -> if "!" `isPrefixOf` x-                                                then (drop 1 x, False)-                                                else (x, True)) $-                                     words grp2)+  return $+    unfoldForest (unfold thresholds) $+      map root $ filter (null . snd) thresholds+  where+    getThresholds = mapMaybe findThreshold . lines+    regex = makeRegex ("(.*)\\ \\(threshold\\ \\((.*)\\)\\)" :: String) -        unfold thresholds ((parent, parent_cmp), ancestors) =-          let ancestors' = parent : ancestors+    findThreshold :: String -> Maybe (String, [(String, Bool)])+    findThreshold l = do+      [grp1, grp2] <- regexGroups regex l+      return+        ( grp1,+          filter (not . null . fst) $+            map+              ( \x ->+                  if "!" `isPrefixOf` x+                    then (drop 1 x, False)+                    else (x, True)+              )+              $ words grp2+        ) -              isChild (v, v_ancestors) = do-                cmp <- lookup parent v_ancestors-                guard $-                  sort (map fst v_ancestors) ==-                  sort (parent : ancestors)-                return ((v, cmp), ancestors')+    unfold thresholds ((parent, parent_cmp), ancestors) =+      let ancestors' = parent : ancestors -          in ((parent, parent_cmp), mapMaybe isChild thresholds)+          isChild (v, v_ancestors) = do+            cmp <- lookup parent v_ancestors+            guard $+              sort (map fst v_ancestors)+                == sort (parent : ancestors)+            return ((v, cmp), ancestors')+       in ((parent, parent_cmp), mapMaybe isChild thresholds)  --- Doing the atual tuning -tuneThreshold :: AutotuneOptions-              -> [(DatasetName, RunDataset, T.Text)]-              -> Path -> (String, Path)-              -> IO Path+tuneThreshold ::+  AutotuneOptions ->+  [(DatasetName, RunDataset, T.Text)] ->+  Path ->+  (String, Path) ->+  IO Path tuneThreshold opts datasets already_tuned (v, _v_path) = do   (_, threshold) <-     foldM tuneDataset (thresholdMin, thresholdMax) datasets   return $ (v, threshold) : already_tuned-   where     tuneDataset :: (Int, Int) -> (DatasetName, RunDataset, T.Text) -> IO (Int, Int)     tuneDataset (tMin, tMax) (dataset_name, run, entry_point) =-      if not $ isPrefixOf (T.unpack entry_point ++ ".") v then do-        when (optVerbose opts > 0) $-          putStrLn $ unwords [v, "is irrelevant for", T.unpack entry_point]-        return (tMin, tMax)-      else do--        putStrLn $ unwords ["Tuning", v, "on entry point", T.unpack entry_point,-                             "and dataset", dataset_name]+      if not $ isPrefixOf (T.unpack entry_point ++ ".") v+        then do+          when (optVerbose opts > 0) $+            putStrLn $ unwords [v, "is irrelevant for", T.unpack entry_point]+          return (tMin, tMax)+        else do+          putStrLn $+            unwords+              [ "Tuning",+                v,+                "on entry point",+                T.unpack entry_point,+                "and dataset",+                dataset_name+              ] -        sample_run <- run (optTimeout opts) ((v, tMax) : already_tuned)+          sample_run <- run (optTimeout opts) ((v, tMax) : already_tuned) -        case sample_run of-          Left err -> do-            -- If the sampling run fails, we treat it as zero information.-            -- One of our ancestor thresholds will have be set such that-            -- this path is never taken.-            when (optVerbose opts > 0) $ putStrLn $-              "Sampling run failed:\n" ++ err-            return (tMin, tMax)-          Right (cmps, t) -> do-            let ePars = S.toAscList $-                        S.map snd $+          case sample_run of+            Left err -> do+              -- If the sampling run fails, we treat it as zero information.+              -- One of our ancestor thresholds will have be set such that+              -- this path is never taken.+              when (optVerbose opts > 0) $+                putStrLn $+                  "Sampling run failed:\n" ++ err+              return (tMin, tMax)+            Right (cmps, t) -> do+              let ePars =+                    S.toAscList $+                      S.map snd $                         S.filter (candidateEPar (tMin, tMax)) $-                        S.fromList cmps+                          S.fromList cmps -                runner :: Int -> Int -> IO (Maybe Int)-                runner timeout' threshold = do-                  res <- run timeout' ((v, threshold) : already_tuned)-                  case res of-                    Right (_, runTime) ->-                      return $ Just runTime-                    _ ->-                      return Nothing+                  runner :: Int -> Int -> IO (Maybe Int)+                  runner timeout' threshold = do+                    res <- run timeout' ((v, threshold) : already_tuned)+                    case res of+                      Right (_, runTime) ->+                        return $ Just runTime+                      _ ->+                        return Nothing -            when (optVerbose opts > 1) $-              putStrLn $ unwords ("Got ePars: " : map show ePars)+              when (optVerbose opts > 1) $+                putStrLn $ unwords ("Got ePars: " : map show ePars) -            newMax <- binarySearch runner (t, tMax) ePars-            let newMinIdx = pred <$> elemIndex newMax ePars-            let newMin = maxinum $ catMaybes [Just tMin, newMinIdx]-            return (newMin, newMax)+              newMax <- binarySearch runner (t, tMax) ePars+              let newMinIdx = pred <$> elemIndex newMax ePars+              let newMin = maxinum $ catMaybes [Just tMin, newMinIdx]+              return (newMin, newMax)      bestPair :: [(Int, Int)] -> (Int, Int)     bestPair = minimumBy (compare `on` fst)@@ -263,40 +295,49 @@     candidateEPar (tMin, tMax) (threshold, ePar) =       ePar > tMin && ePar < tMax && threshold == v -     binarySearch :: (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int     binarySearch runner best@(best_t, best_e_par) xs =       case splitAt (length xs `div` 2) xs of         (lower, middle : middle' : upper) -> do           when (optVerbose opts > 0) $-            putStrLn $ unwords ["Trying e_par", show middle,-                                "and", show middle']+            putStrLn $+              unwords+                [ "Trying e_par",+                  show middle,+                  "and",+                  show middle'+                ]           candidate <- runner (timeout best_t) middle           candidate' <- runner (timeout best_t) middle'           case (candidate, candidate') of             (Just new_t, Just new_t') ->-              if new_t < new_t' then-                -- recurse into lower half-                binarySearch runner (bestPair [(new_t, middle), best]) lower-              else-                -- recurse into upper half-                binarySearch runner (bestPair [(new_t', middle'), best]) upper+              if new_t < new_t'+                then -- recurse into lower half+                  binarySearch runner (bestPair [(new_t, middle), best]) lower+                else -- recurse into upper half+                  binarySearch runner (bestPair [(new_t', middle'), best]) upper             (Just new_t, Nothing) ->               -- recurse into lower half               binarySearch runner (bestPair [(new_t, middle), best]) lower             (Nothing, Just new_t') ->-                -- recurse into upper half-                binarySearch runner (bestPair [(new_t', middle'), best]) upper+              -- recurse into upper half+              binarySearch runner (bestPair [(new_t', middle'), best]) upper             (Nothing, Nothing) -> do               when (optVerbose opts > 2) $-                putStrLn $ unwords ["Timing failed for candidates",-                                    show middle, "and", show middle']+                putStrLn $+                  unwords+                    [ "Timing failed for candidates",+                      show middle,+                      "and",+                      show middle'+                    ]               return best_e_par         (_, _) -> do           when (optVerbose opts > 0) $             putStrLn $ unwords ["Trying e_pars", show xs]-          candidates <- catMaybes . zipWith (fmap . flip (,)) xs <$>-                        mapM (runner $ timeout best_t) xs+          candidates <-+            catMaybes . zipWith (fmap . flip (,)) xs+              <$> mapM (runner $ timeout best_t) xs           return $ snd $ bestPair $ best : candidates  --- CLI@@ -308,7 +349,7 @@    forest <- thresholdForest prog   when (optVerbose opts > 0) $-    putStrLn $ ("Threshold forest:\n"++) $ drawForest $ map (fmap show) forest+    putStrLn $ ("Threshold forest:\n" ++) $ drawForest $ map (fmap show) forest    foldM (tuneThreshold opts datasets) [] $ tuningPaths forest @@ -316,8 +357,9 @@ runAutotuner opts prog = do   best <- tune opts prog -  let tuning = unlines $ do (s, n) <- sortOn fst best-                            return $ s ++ "=" ++ show n+  let tuning = unlines $ do+        (s, n) <- sortOn fst best+        return $ s ++ "=" ++ show n    case optTuning opts of     Nothing -> return ()@@ -328,54 +370,87 @@   putStrLn $ "Result of autotuning:\n" ++ tuning  commandLineOptions :: [FunOptDescr AutotuneOptions]-commandLineOptions = [-    Option "r" ["runs"]-    (ReqArg (\n ->+commandLineOptions =+  [ Option+      "r"+      ["runs"]+      ( ReqArg+          ( \n ->               case reads n of                 [(n', "")] | n' >= 0 ->                   Right $ \config ->-                  config { optRuns = n'-                         }+                    config+                      { optRuns = n'+                      }                 _ ->-                  Left $ error $ "'" ++ n ++ "' is not a non-negative integer.")-     "RUNS")-    "Run each test case this many times."-  , Option [] ["backend"]-    (ReqArg (\backend -> Right $ \config -> config { optBackend = backend })-     "BACKEND")-    "The compiler used (defaults to 'opencl')."-  , Option [] ["futhark"]-    (ReqArg (\prog -> Right $ \config -> config { optFuthark = Just prog })-     "PROGRAM")-    "The binary used for operations (defaults to 'futhark')."-  , Option [] ["pass-option"]-    (ReqArg (\opt ->-               Right $ \config ->-               config { optExtraOptions = opt : optExtraOptions config })-     "OPT")-    "Pass this option to programs being run."-  , Option [] ["tuning"]-    (ReqArg (\s -> Right $ \config -> config { optTuning = Just s })-    "EXTENSION")-    "Write tuning files with this extension (default: .tuning)."-  , Option [] ["timeout"]-    (ReqArg (\n ->-               case reads n of-                 [(n', "")] ->-                   Right $ \config -> config { optTimeout = n' }-                 _ ->-                   Left $ error $ "'" ++ n ++ "' is not a non-negative integer.")-    "SECONDS")-    "Initial tuning timeout for each dataset. Later tuning runs are based off of the runtime of the first run."-  , Option "v" ["verbose"]-    (NoArg $ Right $ \config -> config { optVerbose = optVerbose config + 1 })-    "Enable logging.  Pass multiple times for more."-   ]+                  Left $ error $ "'" ++ n ++ "' is not a non-negative integer."+          )+          "RUNS"+      )+      "Run each test case this many times.",+    Option+      []+      ["backend"]+      ( ReqArg+          (\backend -> Right $ \config -> config {optBackend = backend})+          "BACKEND"+      )+      "The compiler used (defaults to 'opencl').",+    Option+      []+      ["futhark"]+      ( ReqArg+          (\prog -> Right $ \config -> config {optFuthark = Just prog})+          "PROGRAM"+      )+      "The binary used for operations (defaults to 'futhark').",+    Option+      []+      ["pass-option"]+      ( ReqArg+          ( \opt ->+              Right $ \config ->+                config {optExtraOptions = opt : optExtraOptions config}+          )+          "OPT"+      )+      "Pass this option to programs being run.",+    Option+      []+      ["tuning"]+      ( ReqArg+          (\s -> Right $ \config -> config {optTuning = Just s})+          "EXTENSION"+      )+      "Write tuning files with this extension (default: .tuning).",+    Option+      []+      ["timeout"]+      ( ReqArg+          ( \n ->+              case reads n of+                [(n', "")] ->+                  Right $ \config -> config {optTimeout = n'}+                _ ->+                  Left $ error $ "'" ++ n ++ "' is not a non-negative integer."+          )+          "SECONDS"+      )+      "Initial tuning timeout for each dataset. Later tuning runs are based off of the runtime of the first run.",+    Option+      "v"+      ["verbose"]+      (NoArg $ Right $ \config -> config {optVerbose = optVerbose config + 1})+      "Enable logging.  Pass multiple times for more."+  ]  -- | Run @futhark autotune@ main :: String -> [String] -> IO ()-main = mainWithOptions initialAutotuneOptions commandLineOptions-       "options... program" $-       \progs config ->-         case progs of [prog] -> Just $ runAutotuner config prog-                       _      -> Nothing+main = mainWithOptions+  initialAutotuneOptions+  commandLineOptions+  "options... program"+  $ \progs config ->+    case progs of+      [prog] -> Just $ runAutotuner config prog+      _ -> Nothing