futhark 0.12.1 → 0.12.2
raw patch · 111 files changed
+3231/−2636 lines, 111 filesdep +unordered-containersdep ~base
Dependencies added: unordered-containers
Dependency ranges changed: base
Files
- docs/man/futhark-autotune.rst +66/−0
- docs/man/futhark.rst +7/−0
- futhark.cabal +14/−9
- futlib/functional.fut +6/−2
- futlib/math.fut +206/−223
- futlib/soacs.fut +1/−1
- package.yaml +3/−2
- rts/csharp/scalar.cs +7/−0
- rts/python/__init__.py +0/−0
- rts/python/scalar.py +18/−0
- src/Futhark/Analysis/DataDependencies.hs +2/−1
- src/Futhark/Analysis/HORepresentation/SOAC.hs +17/−18
- src/Futhark/Analysis/PrimExp.hs +8/−2
- src/Futhark/Analysis/ScalExp.hs +0/−1
- src/Futhark/Bench.hs +246/−0
- src/Futhark/Binder/Class.hs +2/−1
- src/Futhark/CLI/Autotune.hs +323/−0
- src/Futhark/CLI/Bench.hs +36/−170
- src/Futhark/CLI/Doc.hs +0/−1
- src/Futhark/CLI/Misc.hs +36/−1
- src/Futhark/CLI/Pkg.hs +2/−0
- src/Futhark/CodeGen/Backends/CCUDA.hs +27/−7
- src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +5/−4
- src/Futhark/CodeGen/Backends/COpenCL.hs +16/−10
- src/Futhark/CodeGen/Backends/CSOpenCL.hs +6/−7
- src/Futhark/CodeGen/Backends/GenericC.hs +17/−10
- src/Futhark/CodeGen/Backends/GenericCSharp.hs +13/−13
- src/Futhark/CodeGen/Backends/GenericPython.hs +9/−9
- src/Futhark/CodeGen/Backends/PyOpenCL.hs +6/−7
- src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +1/−1
- src/Futhark/CodeGen/Backends/SimpleRepresentation.hs +59/−8
- src/Futhark/CodeGen/ImpCode.hs +10/−11
- src/Futhark/CodeGen/ImpCode/Kernels.hs +2/−8
- src/Futhark/CodeGen/ImpGen.hs +26/−16
- src/Futhark/CodeGen/ImpGen/Kernels.hs +35/−7
- src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +143/−62
- src/Futhark/CodeGen/ImpGen/Kernels/SegGenRed.hs +0/−669
- src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +875/−0
- src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +14/−16
- src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +3/−5
- src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +22/−22
- src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +1/−1
- src/Futhark/CodeGen/SetDefaultSpace.hs +1/−1
- src/Futhark/Internalise.hs +21/−18
- src/Futhark/Internalise/Bindings.hs +0/−2
- src/Futhark/Internalise/Defunctionalise.hs +9/−9
- src/Futhark/Internalise/Defunctorise.hs +4/−4
- src/Futhark/Internalise/Monomorphise.hs +4/−4
- src/Futhark/Internalise/TypesValues.hs +2/−3
- src/Futhark/Optimise/Fusion.hs +5/−5
- src/Futhark/Optimise/Fusion/LoopKernel.hs +11/−29
- src/Futhark/Optimise/InPlaceLowering.hs +3/−3
- src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +0/−1
- src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +0/−1
- src/Futhark/Optimise/Simplify/Engine.hs +33/−13
- src/Futhark/Optimise/Simplify/Lore.hs +2/−1
- src/Futhark/Optimise/Simplify/Rules.hs +1/−2
- src/Futhark/Optimise/TileLoops.hs +10/−8
- src/Futhark/Pass/ExpandAllocations.hs +13/−14
- src/Futhark/Pass/ExplicitAllocations.hs +20/−19
- src/Futhark/Pass/ExtractKernels.hs +11/−4
- src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +35/−56
- src/Futhark/Pass/ExtractKernels/DistributeNests.hs +41/−31
- src/Futhark/Pass/ExtractKernels/Distribution.hs +1/−1
- src/Futhark/Pass/ExtractKernels/Intragroup.hs +13/−2
- src/Futhark/Pass/KernelBabysitting.hs +9/−11
- src/Futhark/Passes.hs +1/−0
- src/Futhark/Pkg/Info.hs +9/−11
- src/Futhark/Pkg/Solve.hs +0/−1
- src/Futhark/Pkg/Types.hs +1/−1
- src/Futhark/Representation/AST/Annotations.hs +10/−8
- src/Futhark/Representation/AST/Attributes.hs +1/−1
- src/Futhark/Representation/AST/Attributes/Aliases.hs +2/−2
- src/Futhark/Representation/AST/Attributes/Ranges.hs +2/−2
- src/Futhark/Representation/AST/Attributes/Reshape.hs +2/−0
- src/Futhark/Representation/AST/Attributes/Types.hs +0/−1
- src/Futhark/Representation/AST/Pretty.hs +1/−3
- src/Futhark/Representation/AST/Syntax/Core.hs +0/−1
- src/Futhark/Representation/AST/Traversals.hs +0/−1
- src/Futhark/Representation/Aliases.hs +0/−1
- src/Futhark/Representation/ExplicitMemory.hs +7/−8
- src/Futhark/Representation/Kernels.hs +1/−1
- src/Futhark/Representation/Kernels/Kernel.hs +176/−123
- src/Futhark/Representation/Kernels/KernelExp.hs +0/−607
- src/Futhark/Representation/Kernels/Simplify.hs +18/−13
- src/Futhark/Representation/Primitive.hs +30/−1
- src/Futhark/Representation/Ranges.hs +0/−1
- src/Futhark/Representation/SOACS/SOAC.hs +44/−39
- src/Futhark/Representation/SOACS/Simplify.hs +5/−4
- src/Futhark/Test.hs +9/−4
- src/Futhark/Transform/FirstOrderTransform.hs +7/−7
- src/Futhark/Util.hs +22/−2
- src/Language/Futhark/Attributes.hs +22/−12
- src/Language/Futhark/Interpreter.hs +33/−16
- src/Language/Futhark/Parser/Lexer.x +4/−4
- src/Language/Futhark/Parser/Parser.y +23/−21
- src/Language/Futhark/Pretty.hs +11/−8
- src/Language/Futhark/Syntax.hs +1/−1
- src/Language/Futhark/Traversals.hs +3/−2
- src/Language/Futhark/TypeChecker/Monad.hs +32/−32
- src/Language/Futhark/TypeChecker/Terms.hs +150/−112
- src/Language/Futhark/TypeChecker/Types.hs +3/−5
- src/Language/Futhark/TypeChecker/Unify.hs +17/−6
- src/futhark.hs +5/−2
- unittests/Futhark/Analysis/ScalExpTests.hs +1/−1
- unittests/Futhark/BenchTests.hs +35/−0
- unittests/Futhark/Representation/AST/AttributesTests.hs +1/−1
- unittests/Futhark/Representation/ExplicitMemory/IndexFunction/Alg.hs +0/−1
- unittests/Language/Futhark/CoreTests.hs +1/−1
- unittests/Language/Futhark/SyntaxTests.hs +0/−1
- unittests/futhark_tests.hs +2/−0
+ docs/man/futhark-autotune.rst view
@@ -0,0 +1,66 @@+.. role:: ref(emphasis)++.. _futhark-autotune(1):++================+futhark-autotune+================++SYNOPSIS+========++futhark autotune [options...] program++DESCRIPTION+===========++``futhark-autotune`` attemps to find optimal values for threshold+parameters given representative datasets. This is done by repeatedly+running running the program through :ref:`futhark-bench(1)` with+different values for the threshold parameters. When+``futhark-autotune`` finishes tuning a program ``foo.fut``, the+results are written to ``foo.fut.tuning``, which will then+automatically be picked up by subsequent uses of+:ref:`futhark-bench(1)` and :ref:`futhark-test(1)`.++Currently, only the entry point named ``main`` is tuned.+++OPTIONS+=======++--backend=name++ The backend used when compiling Futhark programs (without leading+ ``futhark``, e.g. just ``opencl``).++--futhark=program++ The program used to perform operations (eg. compilation). Defaults+ to the binary running ``futhark autotune`` itself.++--pass-option=opt++ Pass an option to programs that are being run. For example, we+ might want to run OpenCL programs on a specific device::++ futhark autotune prog.fut --backend=opencl --pass-option=-dHawaii++--runs=count++ The number of runs per data set.++-v, --verbose++ Print verbose information about what the tuner is doing. Pass+ multiple times to increase the amount of information printed.++--tuning=EXTENSION++ Change the extension used for tuning files (``.tuning`` by default).+++SEE ALSO+========++:ref:`futhark-bench(1)`
docs/man/futhark.rst view
@@ -39,6 +39,13 @@ is in contrast to :ref:`futhark-test(1)`, which only reports the first one. +futhark dataget PROGRAM DATASET+-------------------------------++Find the test dataset whose description contains ``DATASET``+(e.g. ``#1``) and print it in binary representation to standard+output.+ futhark dev options... PROGRAM ------------------------------
futhark.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.32.0. -- -- see: https://github.com/sol/hpack ----- hash: 38e40072e41929349f42259546b30abfbce169d4641549f5f1d5db10f60f2724+-- hash: 6f8ebcf4ed2412437b0237651acb344581aeadbae4524bcbcb98189e63ce02f5 name: futhark-version: 0.12.1+version: 0.12.2 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to efficient parallel code. It is a statically typed, data-parallel,@@ -25,6 +25,7 @@ license-file: LICENSE build-type: Simple extra-source-files:+ rts/python/__init__.py rts/python/memory.py rts/python/opencl.py rts/python/panic.py@@ -57,6 +58,7 @@ docs/Makefile docs/conf.py docs/index.rst+ docs/man/futhark-autotune.rst docs/man/futhark-bench.rst docs/man/futhark-c.rst docs/man/futhark-csharp.rst@@ -97,8 +99,10 @@ Futhark.Analysis.SymbolTable Futhark.Analysis.Usage Futhark.Analysis.UsageTable+ Futhark.Bench Futhark.Binder Futhark.Binder.Class+ Futhark.CLI.Autotune Futhark.CLI.Bench Futhark.CLI.C Futhark.CLI.CSharp@@ -146,7 +150,7 @@ Futhark.CodeGen.ImpGen.CUDA Futhark.CodeGen.ImpGen.Kernels Futhark.CodeGen.ImpGen.Kernels.Base- Futhark.CodeGen.ImpGen.Kernels.SegGenRed+ Futhark.CodeGen.ImpGen.Kernels.SegHist Futhark.CodeGen.ImpGen.Kernels.SegMap Futhark.CodeGen.ImpGen.Kernels.SegRed Futhark.CodeGen.ImpGen.Kernels.SegScan@@ -235,7 +239,6 @@ Futhark.Representation.ExplicitMemory.Simplify Futhark.Representation.Kernels Futhark.Representation.Kernels.Kernel- Futhark.Representation.Kernels.KernelExp Futhark.Representation.Kernels.Simplify Futhark.Representation.Kernels.Sizes Futhark.Representation.Primitive@@ -282,11 +285,14 @@ hs-source-dirs: src ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists+ build-tools:+ alex+ , happy build-depends: aeson >=1.0.0.0 , ansi-terminal >=0.6.3.1 , array >=0.4- , base >=4 && <5+ , base >=4.13 && <5 , binary >=0.8.3 , blaze-html >=0.9.0.1 , bytestring >=0.10.8@@ -322,15 +328,13 @@ , text >=1.2.2.2 , time >=1.6.0.1 , transformers >=0.3+ , unordered-containers >=0.2.7 , utf8-string >=1 , vector >=0.12 , vector-binary-instances >=0.2.2.0 , versions >=3.3.1 , zip-archive >=0.3.1.1 , zlib >=0.6.1.2- build-tools:- alex- , happy default-language: Haskell2010 executable futhark@@ -349,6 +353,7 @@ main-is: futhark_tests.hs other-modules: Futhark.Analysis.ScalExpTests+ Futhark.BenchTests Futhark.Optimise.AlgSimplifyTests Futhark.Pkg.SolveTests Futhark.Representation.AST.Attributes.RearrangeTests
futlib/functional.fut view
@@ -3,7 +3,9 @@ -- | Left-to-right application. Particularly useful for describing -- computation pipelines: ----- x |> f |> g |> h+-- ```+-- x |> f |> g |> h+-- ``` let (|>) '^a '^b (x: a) (f: a -> b): b = f x -- | Right to left application.@@ -18,7 +20,9 @@ -- | Flip the arguments passed to a function. ----- f x y == flip f y x+-- ```+-- f x y == flip f y x+-- ``` let flip '^a '^b '^c (f: a -> b -> c) (b: b) (a: a): c = f a b
futlib/math.fut view
@@ -34,6 +34,7 @@ val -: t -> t -> t val *: t -> t -> t val /: t -> t -> t+ val %: t -> t -> t val **: t -> t -> t val to_i64: t -> i64@@ -76,7 +77,6 @@ module type integral = { include numeric - val %: t -> t -> t val //: t -> t -> t val %%: t -> t -> t @@ -124,6 +124,9 @@ val atan2: t -> t -> t val gamma: t -> t val lgamma: t -> t+ -- | Linear interpolation. The third argument must be in the range+ -- `[0,1]` or the results are unspecified.+ val lerp: t -> t -> t -> t -- | Natural logarithm. val log: t -> t@@ -193,23 +196,23 @@ module i8: (size with t = i8) = { type t = i8 - let (x: i8) + (y: i8) = intrinsics.add8 x y- let (x: i8) - (y: i8) = intrinsics.sub8 x y- let (x: i8) * (y: i8) = intrinsics.mul8 x y- let (x: i8) / (y: i8) = intrinsics.sdiv8 x y- let (x: i8) ** (y: i8) = intrinsics.pow8 x y- let (x: i8) % (y: i8) = intrinsics.smod8 x y- let (x: i8) // (y: i8) = intrinsics.squot8 x y- let (x: i8) %% (y: i8) = intrinsics.srem8 x y+ let (x: i8) + (y: i8) = intrinsics.add8 (x, y)+ let (x: i8) - (y: i8) = intrinsics.sub8 (x, y)+ let (x: i8) * (y: i8) = intrinsics.mul8 (x, y)+ let (x: i8) / (y: i8) = intrinsics.sdiv8 (x, y)+ let (x: i8) ** (y: i8) = intrinsics.pow8 (x, y)+ let (x: i8) % (y: i8) = intrinsics.smod8 (x, y)+ let (x: i8) // (y: i8) = intrinsics.squot8 (x, y)+ let (x: i8) %% (y: i8) = intrinsics.srem8 (x, y) - let (x: i8) & (y: i8) = intrinsics.and8 x y- let (x: i8) | (y: i8) = intrinsics.or8 x y- let (x: i8) ^ (y: i8) = intrinsics.xor8 x y+ let (x: i8) & (y: i8) = intrinsics.and8 (x, y)+ let (x: i8) | (y: i8) = intrinsics.or8 (x, y)+ let (x: i8) ^ (y: i8) = intrinsics.xor8 (x, y) let ! (x: i8) = intrinsics.complement8 x - let (x: i8) << (y: i8) = intrinsics.shl8 x y- let (x: i8) >> (y: i8) = intrinsics.ashr8 x y- let (x: i8) >>> (y: i8) = intrinsics.lshr8 x y+ let (x: i8) << (y: i8) = intrinsics.shl8 (x, y)+ let (x: i8) >> (y: i8) = intrinsics.ashr8 (x, y)+ let (x: i8) >>> (y: i8) = intrinsics.lshr8 (x, y) let i8 (x: i8) = intrinsics.sext_i8_i8 x let i16 (x: i16) = intrinsics.sext_i16_i8 x@@ -229,19 +232,19 @@ let to_i32(x: i8) = intrinsics.sext_i8_i32 x let to_i64(x: i8) = intrinsics.sext_i8_i64 x - let (x: i8) == (y: i8) = intrinsics.eq_i8 x y- let (x: i8) < (y: i8) = intrinsics.slt8 x y- let (x: i8) > (y: i8) = intrinsics.slt8 y x- let (x: i8) <= (y: i8) = intrinsics.sle8 x y- let (x: i8) >= (y: i8) = intrinsics.sle8 y x+ let (x: i8) == (y: i8) = intrinsics.eq_i8 (x, y)+ let (x: i8) < (y: i8) = intrinsics.slt8 (x, y)+ let (x: i8) > (y: i8) = intrinsics.slt8 (y, x)+ let (x: i8) <= (y: i8) = intrinsics.sle8 (x, y)+ let (x: i8) >= (y: i8) = intrinsics.sle8 (y, x) let (x: i8) != (y: i8) = intrinsics.! (x == y) let sgn (x: i8) = intrinsics.ssignum8 x let abs (x: i8) = intrinsics.abs8 x let negate (x: t) = -x- let max (x: t) (y: t) = intrinsics.smax8 x y- let min (x: t) (y: t) = intrinsics.smin8 x y+ let max (x: t) (y: t) = intrinsics.smax8 (x, y)+ let min (x: t) (y: t) = intrinsics.smin8 (x, y) let highest = 127i8 let lowest = highest + 1i8@@ -263,23 +266,23 @@ module i16: (size with t = i16) = { type t = i16 - let (x: i16) + (y: i16) = intrinsics.add16 x y- let (x: i16) - (y: i16) = intrinsics.sub16 x y- let (x: i16) * (y: i16) = intrinsics.mul16 x y- let (x: i16) / (y: i16) = intrinsics.sdiv16 x y- let (x: i16) ** (y: i16) = intrinsics.pow16 x y- let (x: i16) % (y: i16) = intrinsics.smod16 x y- let (x: i16) // (y: i16) = intrinsics.squot16 x y- let (x: i16) %% (y: i16) = intrinsics.srem16 x y+ let (x: i16) + (y: i16) = intrinsics.add16 (x, y)+ let (x: i16) - (y: i16) = intrinsics.sub16 (x, y)+ let (x: i16) * (y: i16) = intrinsics.mul16 (x, y)+ let (x: i16) / (y: i16) = intrinsics.sdiv16 (x, y)+ let (x: i16) ** (y: i16) = intrinsics.pow16 (x, y)+ let (x: i16) % (y: i16) = intrinsics.smod16 (x, y)+ let (x: i16) // (y: i16) = intrinsics.squot16 (x, y)+ let (x: i16) %% (y: i16) = intrinsics.srem16 (x, y) - let (x: i16) & (y: i16) = intrinsics.and16 x y- let (x: i16) | (y: i16) = intrinsics.or16 x y- let (x: i16) ^ (y: i16) = intrinsics.xor16 x y+ let (x: i16) & (y: i16) = intrinsics.and16 (x, y)+ let (x: i16) | (y: i16) = intrinsics.or16 (x, y)+ let (x: i16) ^ (y: i16) = intrinsics.xor16 (x, y) let ! (x: i16) = intrinsics.complement16 x - let (x: i16) << (y: i16) = intrinsics.shl16 x y- let (x: i16) >> (y: i16) = intrinsics.ashr16 x y- let (x: i16) >>> (y: i16) = intrinsics.lshr16 x y+ let (x: i16) << (y: i16) = intrinsics.shl16 (x, y)+ let (x: i16) >> (y: i16) = intrinsics.ashr16 (x, y)+ let (x: i16) >>> (y: i16) = intrinsics.lshr16 (x, y) let i8 (x: i8) = intrinsics.sext_i8_i16 x let i16 (x: i16) = intrinsics.sext_i16_i16 x@@ -299,19 +302,19 @@ let to_i32(x: i16) = intrinsics.sext_i16_i32 x let to_i64(x: i16) = intrinsics.sext_i16_i64 x - let (x: i16) == (y: i16) = intrinsics.eq_i16 x y- let (x: i16) < (y: i16) = intrinsics.slt16 x y- let (x: i16) > (y: i16) = intrinsics.slt16 y x- let (x: i16) <= (y: i16) = intrinsics.sle16 x y- let (x: i16) >= (y: i16) = intrinsics.sle16 y x+ let (x: i16) == (y: i16) = intrinsics.eq_i16 (x, y)+ let (x: i16) < (y: i16) = intrinsics.slt16 (x, y)+ let (x: i16) > (y: i16) = intrinsics.slt16 (y, x)+ let (x: i16) <= (y: i16) = intrinsics.sle16 (x, y)+ let (x: i16) >= (y: i16) = intrinsics.sle16 (y, x) let (x: i16) != (y: i16) = intrinsics.! (x == y) let sgn (x: i16) = intrinsics.ssignum16 x let abs (x: i16) = intrinsics.abs16 x let negate (x: t) = -x- let max (x: t) (y: t) = intrinsics.smax16 x y- let min (x: t) (y: t) = intrinsics.smin16 x y+ let max (x: t) (y: t) = intrinsics.smax16 (x, y)+ let min (x: t) (y: t) = intrinsics.smin16 (x, y) let highest = 32767i16 let lowest = highest + 1i16@@ -336,23 +339,23 @@ let sign (x: u32) = intrinsics.sign_i32 x let unsign (x: i32) = intrinsics.unsign_i32 x - let (x: i32) + (y: i32) = intrinsics.add32 x y- let (x: i32) - (y: i32) = intrinsics.sub32 x y- let (x: i32) * (y: i32) = intrinsics.mul32 x y- let (x: i32) / (y: i32) = intrinsics.sdiv32 x y- let (x: i32) ** (y: i32) = intrinsics.pow32 x y- let (x: i32) % (y: i32) = intrinsics.smod32 x y- let (x: i32) // (y: i32) = intrinsics.squot32 x y- let (x: i32) %% (y: i32) = intrinsics.srem32 x y+ let (x: i32) + (y: i32) = intrinsics.add32 (x, y)+ let (x: i32) - (y: i32) = intrinsics.sub32 (x, y)+ let (x: i32) * (y: i32) = intrinsics.mul32 (x, y)+ let (x: i32) / (y: i32) = intrinsics.sdiv32 (x, y)+ let (x: i32) ** (y: i32) = intrinsics.pow32 (x, y)+ let (x: i32) % (y: i32) = intrinsics.smod32 (x, y)+ let (x: i32) // (y: i32) = intrinsics.squot32 (x, y)+ let (x: i32) %% (y: i32) = intrinsics.srem32 (x, y) - let (x: i32) & (y: i32) = intrinsics.and32 x y- let (x: i32) | (y: i32) = intrinsics.or32 x y- let (x: i32) ^ (y: i32) = intrinsics.xor32 x y+ let (x: i32) & (y: i32) = intrinsics.and32 (x, y)+ let (x: i32) | (y: i32) = intrinsics.or32 (x, y)+ let (x: i32) ^ (y: i32) = intrinsics.xor32 (x, y) let ! (x: i32) = intrinsics.complement32 x - let (x: i32) << (y: i32) = intrinsics.shl32 x y- let (x: i32) >> (y: i32) = intrinsics.ashr32 x y- let (x: i32) >>> (y: i32) = intrinsics.lshr32 x y+ let (x: i32) << (y: i32) = intrinsics.shl32 (x, y)+ let (x: i32) >> (y: i32) = intrinsics.ashr32 (x, y)+ let (x: i32) >>> (y: i32) = intrinsics.lshr32 (x, y) let i8 (x: i8) = intrinsics.sext_i8_i32 x let i16 (x: i16) = intrinsics.sext_i16_i32 x@@ -372,19 +375,19 @@ let to_i32(x: i32) = intrinsics.sext_i32_i32 x let to_i64(x: i32) = intrinsics.sext_i32_i64 x - let (x: i32) == (y: i32) = intrinsics.eq_i32 x y- let (x: i32) < (y: i32) = intrinsics.slt32 x y- let (x: i32) > (y: i32) = intrinsics.slt32 y x- let (x: i32) <= (y: i32) = intrinsics.sle32 x y- let (x: i32) >= (y: i32) = intrinsics.sle32 y x+ let (x: i32) == (y: i32) = intrinsics.eq_i32 (x, y)+ let (x: i32) < (y: i32) = intrinsics.slt32 (x, y)+ let (x: i32) > (y: i32) = intrinsics.slt32 (y, x)+ let (x: i32) <= (y: i32) = intrinsics.sle32 (x, y)+ let (x: i32) >= (y: i32) = intrinsics.sle32 (y, x) let (x: i32) != (y: i32) = intrinsics.! (x == y) let sgn (x: i32) = intrinsics.ssignum32 x let abs (x: i32) = intrinsics.abs32 x let negate (x: t) = -x- let max (x: t) (y: t) = intrinsics.smax32 x y- let min (x: t) (y: t) = intrinsics.smin32 x y+ let max (x: t) (y: t) = intrinsics.smax32 (x, y)+ let min (x: t) (y: t) = intrinsics.smin32 (x, y) let highest = 2147483647 let lowest = highest + 1@@ -409,23 +412,23 @@ let sign (x: u64) = intrinsics.sign_i64 x let unsign (x: i64) = intrinsics.unsign_i64 x - let (x: i64) + (y: i64) = intrinsics.add64 x y- let (x: i64) - (y: i64) = intrinsics.sub64 x y- let (x: i64) * (y: i64) = intrinsics.mul64 x y- let (x: i64) / (y: i64) = intrinsics.sdiv64 x y- let (x: i64) ** (y: i64) = intrinsics.pow64 x y- let (x: i64) % (y: i64) = intrinsics.smod64 x y- let (x: i64) // (y: i64) = intrinsics.squot64 x y- let (x: i64) %% (y: i64) = intrinsics.srem64 x y+ let (x: i64) + (y: i64) = intrinsics.add64 (x, y)+ let (x: i64) - (y: i64) = intrinsics.sub64 (x, y)+ let (x: i64) * (y: i64) = intrinsics.mul64 (x, y)+ let (x: i64) / (y: i64) = intrinsics.sdiv64 (x, y)+ let (x: i64) ** (y: i64) = intrinsics.pow64 (x, y)+ let (x: i64) % (y: i64) = intrinsics.smod64 (x, y)+ let (x: i64) // (y: i64) = intrinsics.squot64 (x, y)+ let (x: i64) %% (y: i64) = intrinsics.srem64 (x, y) - let (x: i64) & (y: i64) = intrinsics.and64 x y- let (x: i64) | (y: i64) = intrinsics.or64 x y- let (x: i64) ^ (y: i64) = intrinsics.xor64 x y+ let (x: i64) & (y: i64) = intrinsics.and64 (x, y)+ let (x: i64) | (y: i64) = intrinsics.or64 (x, y)+ let (x: i64) ^ (y: i64) = intrinsics.xor64 (x, y) let ! (x: i64) = intrinsics.complement64 x - let (x: i64) << (y: i64) = intrinsics.shl64 x y- let (x: i64) >> (y: i64) = intrinsics.ashr64 x y- let (x: i64) >>> (y: i64) = intrinsics.lshr64 x y+ let (x: i64) << (y: i64) = intrinsics.shl64 (x, y)+ let (x: i64) >> (y: i64) = intrinsics.ashr64 (x, y)+ let (x: i64) >>> (y: i64) = intrinsics.lshr64 (x, y) let i8 (x: i8) = intrinsics.sext_i8_i64 x let i16 (x: i16) = intrinsics.sext_i16_i64 x@@ -445,19 +448,19 @@ let to_i32(x: i64) = intrinsics.sext_i64_i32 x let to_i64(x: i64) = intrinsics.sext_i64_i64 x - let (x: i64) == (y: i64) = intrinsics.eq_i64 x y- let (x: i64) < (y: i64) = intrinsics.slt64 x y- let (x: i64) > (y: i64) = intrinsics.slt64 y x- let (x: i64) <= (y: i64) = intrinsics.sle64 x y- let (x: i64) >= (y: i64) = intrinsics.sle64 y x+ let (x: i64) == (y: i64) = intrinsics.eq_i64 (x, y)+ let (x: i64) < (y: i64) = intrinsics.slt64 (x, y)+ let (x: i64) > (y: i64) = intrinsics.slt64 (y, x)+ let (x: i64) <= (y: i64) = intrinsics.sle64 (x, y)+ let (x: i64) >= (y: i64) = intrinsics.sle64 (y, x) let (x: i64) != (y: i64) = intrinsics.! (x == y) let sgn (x: i64) = intrinsics.ssignum64 x let abs (x: i64) = intrinsics.abs64 x let negate (x: t) = -x- let max (x: t) (y: t) = intrinsics.smax64 x y- let min (x: t) (y: t) = intrinsics.smin64 x y+ let max (x: t) (y: t) = intrinsics.smax64 (x, y)+ let min (x: t) (y: t) = intrinsics.smin64 (x, y) let highest = 9223372036854775807i64 let lowest = highest + 1i64@@ -482,23 +485,23 @@ let sign (x: u8) = intrinsics.sign_i8 x let unsign (x: i8) = intrinsics.unsign_i8 x - let (x: u8) + (y: u8) = unsign (intrinsics.add8 (sign x) (sign y))- let (x: u8) - (y: u8) = unsign (intrinsics.sub8 (sign x) (sign y))- let (x: u8) * (y: u8) = unsign (intrinsics.mul8 (sign x) (sign y))- let (x: u8) / (y: u8) = unsign (intrinsics.udiv8 (sign x) (sign y))- let (x: u8) ** (y: u8) = unsign (intrinsics.pow8 (sign x) (sign y))- let (x: u8) % (y: u8) = unsign (intrinsics.umod8 (sign x) (sign y))- let (x: u8) // (y: u8) = unsign (intrinsics.udiv8 (sign x) (sign y))- let (x: u8) %% (y: u8) = unsign (intrinsics.umod8 (sign x) (sign y))+ let (x: u8) + (y: u8) = unsign (intrinsics.add8 (sign x, sign y))+ let (x: u8) - (y: u8) = unsign (intrinsics.sub8 (sign x, sign y))+ let (x: u8) * (y: u8) = unsign (intrinsics.mul8 (sign x, sign y))+ let (x: u8) / (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))+ let (x: u8) ** (y: u8) = unsign (intrinsics.pow8 (sign x, sign y))+ let (x: u8) % (y: u8) = unsign (intrinsics.umod8 (sign x, sign y))+ let (x: u8) // (y: u8) = unsign (intrinsics.udiv8 (sign x, sign y))+ let (x: u8) %% (y: u8) = unsign (intrinsics.umod8 (sign x, sign y)) - let (x: u8) & (y: u8) = unsign (intrinsics.and8 (sign x) (sign y))- let (x: u8) | (y: u8) = unsign (intrinsics.or8 (sign x) (sign y))- let (x: u8) ^ (y: u8) = unsign (intrinsics.xor8 (sign x) (sign y))+ let (x: u8) & (y: u8) = unsign (intrinsics.and8 (sign x, sign y))+ let (x: u8) | (y: u8) = unsign (intrinsics.or8 (sign x, sign y))+ let (x: u8) ^ (y: u8) = unsign (intrinsics.xor8 (sign x, sign y)) let ! (x: u8) = unsign (intrinsics.complement8 (sign x)) - let (x: u8) << (y: u8) = unsign (intrinsics.shl8 (sign x) (sign y))- let (x: u8) >> (y: u8) = unsign (intrinsics.ashr8 (sign x) (sign y))- let (x: u8) >>> (y: u8) = unsign (intrinsics.lshr8 (sign x) (sign y))+ let (x: u8) << (y: u8) = unsign (intrinsics.shl8 (sign x, sign y))+ let (x: u8) >> (y: u8) = unsign (intrinsics.ashr8 (sign x, sign y))+ let (x: u8) >>> (y: u8) = unsign (intrinsics.lshr8 (sign x, sign y)) let u8 (x: u8) = unsign (i8.u8 x) let u16 (x: u16) = unsign (i8.u16 x)@@ -518,19 +521,19 @@ let to_i32(x: u8) = intrinsics.zext_i8_i32 (sign x) let to_i64(x: u8) = intrinsics.zext_i8_i64 (sign x) - let (x: u8) == (y: u8) = intrinsics.eq_i8 (sign x) (sign y)- let (x: u8) < (y: u8) = intrinsics.ult8 (sign x) (sign y)- let (x: u8) > (y: u8) = intrinsics.ult8 (sign y) (sign x)- let (x: u8) <= (y: u8) = intrinsics.ule8 (sign x) (sign y)- let (x: u8) >= (y: u8) = intrinsics.ule8 (sign y) (sign x)+ let (x: u8) == (y: u8) = intrinsics.eq_i8 (sign x, sign y)+ let (x: u8) < (y: u8) = intrinsics.ult8 (sign x, sign y)+ let (x: u8) > (y: u8) = intrinsics.ult8 (sign y, sign x)+ let (x: u8) <= (y: u8) = intrinsics.ule8 (sign x, sign y)+ let (x: u8) >= (y: u8) = intrinsics.ule8 (sign y, sign x) let (x: u8) != (y: u8) = intrinsics.! (x == y) let sgn (x: u8) = unsign (intrinsics.usignum8 (sign x)) let abs (x: u8) = x let negate (x: t) = -x- let max (x: t) (y: t) = unsign (intrinsics.umax8 (sign x) (sign y))- let min (x: t) (y: t) = unsign (intrinsics.umin8 (sign x) (sign y))+ let max (x: t) (y: t) = unsign (intrinsics.umax8 (sign x, sign y))+ let min (x: t) (y: t) = unsign (intrinsics.umin8 (sign x, sign y)) let highest = 255u8 let lowest = 0u8@@ -555,23 +558,23 @@ let sign (x: u16) = intrinsics.sign_i16 x let unsign (x: i16) = intrinsics.unsign_i16 x - let (x: u16) + (y: u16) = unsign (intrinsics.add16 (sign x) (sign y))- let (x: u16) - (y: u16) = unsign (intrinsics.sub16 (sign x) (sign y))- let (x: u16) * (y: u16) = unsign (intrinsics.mul16 (sign x) (sign y))- let (x: u16) / (y: u16) = unsign (intrinsics.udiv16 (sign x) (sign y))- let (x: u16) ** (y: u16) = unsign (intrinsics.pow16 (sign x) (sign y))- let (x: u16) % (y: u16) = unsign (intrinsics.umod16 (sign x) (sign y))- let (x: u16) // (y: u16) = unsign (intrinsics.udiv16 (sign x) (sign y))- let (x: u16) %% (y: u16) = unsign (intrinsics.umod16 (sign x) (sign y))+ let (x: u16) + (y: u16) = unsign (intrinsics.add16 (sign x, sign y))+ let (x: u16) - (y: u16) = unsign (intrinsics.sub16 (sign x, sign y))+ let (x: u16) * (y: u16) = unsign (intrinsics.mul16 (sign x, sign y))+ let (x: u16) / (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))+ let (x: u16) ** (y: u16) = unsign (intrinsics.pow16 (sign x, sign y))+ let (x: u16) % (y: u16) = unsign (intrinsics.umod16 (sign x, sign y))+ let (x: u16) // (y: u16) = unsign (intrinsics.udiv16 (sign x, sign y))+ let (x: u16) %% (y: u16) = unsign (intrinsics.umod16 (sign x, sign y)) - let (x: u16) & (y: u16) = unsign (intrinsics.and16 (sign x) (sign y))- let (x: u16) | (y: u16) = unsign (intrinsics.or16 (sign x) (sign y))- let (x: u16) ^ (y: u16) = unsign (intrinsics.xor16 (sign x) (sign y))+ let (x: u16) & (y: u16) = unsign (intrinsics.and16 (sign x, sign y))+ let (x: u16) | (y: u16) = unsign (intrinsics.or16 (sign x, sign y))+ let (x: u16) ^ (y: u16) = unsign (intrinsics.xor16 (sign x, sign y)) let ! (x: u16) = unsign (intrinsics.complement16 (sign x)) - let (x: u16) << (y: u16) = unsign (intrinsics.shl16 (sign x) (sign y))- let (x: u16) >> (y: u16) = unsign (intrinsics.ashr16 (sign x) (sign y))- let (x: u16) >>> (y: u16) = unsign (intrinsics.lshr16 (sign x) (sign y))+ let (x: u16) << (y: u16) = unsign (intrinsics.shl16 (sign x, sign y))+ let (x: u16) >> (y: u16) = unsign (intrinsics.ashr16 (sign x, sign y))+ let (x: u16) >>> (y: u16) = unsign (intrinsics.lshr16 (sign x, sign y)) let u8 (x: u8) = unsign (i16.u8 x) let u16 (x: u16) = unsign (i16.u16 x)@@ -591,19 +594,19 @@ let to_i32(x: u16) = intrinsics.zext_i16_i32 (sign x) let to_i64(x: u16) = intrinsics.zext_i16_i64 (sign x) - let (x: u16) == (y: u16) = intrinsics.eq_i16 (sign x) (sign y)- let (x: u16) < (y: u16) = intrinsics.ult16 (sign x) (sign y)- let (x: u16) > (y: u16) = intrinsics.ult16 (sign y) (sign x)- let (x: u16) <= (y: u16) = intrinsics.ule16 (sign x) (sign y)- let (x: u16) >= (y: u16) = intrinsics.ule16 (sign y) (sign x)+ let (x: u16) == (y: u16) = intrinsics.eq_i16 (sign x, sign y)+ let (x: u16) < (y: u16) = intrinsics.ult16 (sign x, sign y)+ let (x: u16) > (y: u16) = intrinsics.ult16 (sign y, sign x)+ let (x: u16) <= (y: u16) = intrinsics.ule16 (sign x, sign y)+ let (x: u16) >= (y: u16) = intrinsics.ule16 (sign y, sign x) let (x: u16) != (y: u16) = intrinsics.! (x == y) let sgn (x: u16) = unsign (intrinsics.usignum16 (sign x)) let abs (x: u16) = x let negate (x: t) = -x- let max (x: t) (y: t) = unsign (intrinsics.umax16 (sign x) (sign y))- let min (x: t) (y: t) = unsign (intrinsics.umin16 (sign x) (sign y))+ let max (x: t) (y: t) = unsign (intrinsics.umax16 (sign x, sign y))+ let min (x: t) (y: t) = unsign (intrinsics.umin16 (sign x, sign y)) let highest = 65535u16 let lowest = 0u16@@ -628,23 +631,23 @@ let sign (x: u32) = intrinsics.sign_i32 x let unsign (x: i32) = intrinsics.unsign_i32 x - let (x: u32) + (y: u32) = unsign (intrinsics.add32 (sign x) (sign y))- let (x: u32) - (y: u32) = unsign (intrinsics.sub32 (sign x) (sign y))- let (x: u32) * (y: u32) = unsign (intrinsics.mul32 (sign x) (sign y))- let (x: u32) / (y: u32) = unsign (intrinsics.udiv32 (sign x) (sign y))- let (x: u32) ** (y: u32) = unsign (intrinsics.pow32 (sign x) (sign y))- let (x: u32) % (y: u32) = unsign (intrinsics.umod32 (sign x) (sign y))- let (x: u32) // (y: u32) = unsign (intrinsics.udiv32 (sign x) (sign y))- let (x: u32) %% (y: u32) = unsign (intrinsics.umod32 (sign x) (sign y))+ let (x: u32) + (y: u32) = unsign (intrinsics.add32 (sign x, sign y))+ let (x: u32) - (y: u32) = unsign (intrinsics.sub32 (sign x, sign y))+ let (x: u32) * (y: u32) = unsign (intrinsics.mul32 (sign x, sign y))+ let (x: u32) / (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))+ let (x: u32) ** (y: u32) = unsign (intrinsics.pow32 (sign x, sign y))+ let (x: u32) % (y: u32) = unsign (intrinsics.umod32 (sign x, sign y))+ let (x: u32) // (y: u32) = unsign (intrinsics.udiv32 (sign x, sign y))+ let (x: u32) %% (y: u32) = unsign (intrinsics.umod32 (sign x, sign y)) - let (x: u32) & (y: u32) = unsign (intrinsics.and32 (sign x) (sign y))- let (x: u32) | (y: u32) = unsign (intrinsics.or32 (sign x) (sign y))- let (x: u32) ^ (y: u32) = unsign (intrinsics.xor32 (sign x) (sign y))+ let (x: u32) & (y: u32) = unsign (intrinsics.and32 (sign x, sign y))+ let (x: u32) | (y: u32) = unsign (intrinsics.or32 (sign x, sign y))+ let (x: u32) ^ (y: u32) = unsign (intrinsics.xor32 (sign x, sign y)) let ! (x: u32) = unsign (intrinsics.complement32 (sign x)) - let (x: u32) << (y: u32) = unsign (intrinsics.shl32 (sign x) (sign y))- let (x: u32) >> (y: u32) = unsign (intrinsics.ashr32 (sign x) (sign y))- let (x: u32) >>> (y: u32) = unsign (intrinsics.lshr32 (sign x) (sign y))+ let (x: u32) << (y: u32) = unsign (intrinsics.shl32 (sign x, sign y))+ let (x: u32) >> (y: u32) = unsign (intrinsics.ashr32 (sign x, sign y))+ let (x: u32) >>> (y: u32) = unsign (intrinsics.lshr32 (sign x, sign y)) let u8 (x: u8) = unsign (i32.u8 x) let u16 (x: u16) = unsign (i32.u16 x)@@ -664,11 +667,11 @@ let to_i32(x: u32) = intrinsics.zext_i32_i32 (sign x) let to_i64(x: u32) = intrinsics.zext_i32_i64 (sign x) - let (x: u32) == (y: u32) = intrinsics.eq_i32 (sign x) (sign y)- let (x: u32) < (y: u32) = intrinsics.ult32 (sign x) (sign y)- let (x: u32) > (y: u32) = intrinsics.ult32 (sign y) (sign x)- let (x: u32) <= (y: u32) = intrinsics.ule32 (sign x) (sign y)- let (x: u32) >= (y: u32) = intrinsics.ule32 (sign y) (sign x)+ let (x: u32) == (y: u32) = intrinsics.eq_i32 (sign x, sign y)+ let (x: u32) < (y: u32) = intrinsics.ult32 (sign x, sign y)+ let (x: u32) > (y: u32) = intrinsics.ult32 (sign y, sign x)+ let (x: u32) <= (y: u32) = intrinsics.ule32 (sign x, sign y)+ let (x: u32) >= (y: u32) = intrinsics.ule32 (sign y, sign x) let (x: u32) != (y: u32) = intrinsics.! (x == y) let sgn (x: u32) = unsign (intrinsics.usignum32 (sign x))@@ -678,8 +681,8 @@ let lowest = highest + 1u32 let negate (x: t) = -x- let max (x: t) (y: t) = unsign (intrinsics.umax32 (sign x) (sign y))- let min (x: t) (y: t) = unsign (intrinsics.umin32 (sign x) (sign y))+ let max (x: t) (y: t) = unsign (intrinsics.umax32 (sign x, sign y))+ let min (x: t) (y: t) = unsign (intrinsics.umin32 (sign x, sign y)) let num_bits = 32 let get_bit (bit: i32) (x: t) = to_i32 ((x >> i32 bit) & i32 1)@@ -701,23 +704,23 @@ let sign (x: u64) = intrinsics.sign_i64 x let unsign (x: i64) = intrinsics.unsign_i64 x - let (x: u64) + (y: u64) = unsign (intrinsics.add64 (sign x) (sign y))- let (x: u64) - (y: u64) = unsign (intrinsics.sub64 (sign x) (sign y))- let (x: u64) * (y: u64) = unsign (intrinsics.mul64 (sign x) (sign y))- let (x: u64) / (y: u64) = unsign (intrinsics.udiv64 (sign x) (sign y))- let (x: u64) ** (y: u64) = unsign (intrinsics.pow64 (sign x) (sign y))- let (x: u64) % (y: u64) = unsign (intrinsics.umod64 (sign x) (sign y))- let (x: u64) // (y: u64) = unsign (intrinsics.udiv64 (sign x) (sign y))- let (x: u64) %% (y: u64) = unsign (intrinsics.umod64 (sign x) (sign y))+ let (x: u64) + (y: u64) = unsign (intrinsics.add64 (sign x, sign y))+ let (x: u64) - (y: u64) = unsign (intrinsics.sub64 (sign x, sign y))+ let (x: u64) * (y: u64) = unsign (intrinsics.mul64 (sign x, sign y))+ let (x: u64) / (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))+ let (x: u64) ** (y: u64) = unsign (intrinsics.pow64 (sign x, sign y))+ let (x: u64) % (y: u64) = unsign (intrinsics.umod64 (sign x, sign y))+ let (x: u64) // (y: u64) = unsign (intrinsics.udiv64 (sign x, sign y))+ let (x: u64) %% (y: u64) = unsign (intrinsics.umod64 (sign x, sign y)) - let (x: u64) & (y: u64) = unsign (intrinsics.and64 (sign x) (sign y))- let (x: u64) | (y: u64) = unsign (intrinsics.or64 (sign x) (sign y))- let (x: u64) ^ (y: u64) = unsign (intrinsics.xor64 (sign x) (sign y))+ let (x: u64) & (y: u64) = unsign (intrinsics.and64 (sign x, sign y))+ let (x: u64) | (y: u64) = unsign (intrinsics.or64 (sign x, sign y))+ let (x: u64) ^ (y: u64) = unsign (intrinsics.xor64 (sign x, sign y)) let ! (x: u64) = unsign (intrinsics.complement64 (sign x)) - let (x: u64) << (y: u64) = unsign (intrinsics.shl64 (sign x) (sign y))- let (x: u64) >> (y: u64) = unsign (intrinsics.ashr64 (sign x) (sign y))- let (x: u64) >>> (y: u64) = unsign (intrinsics.lshr64 (sign x) (sign y))+ let (x: u64) << (y: u64) = unsign (intrinsics.shl64 (sign x, sign y))+ let (x: u64) >> (y: u64) = unsign (intrinsics.ashr64 (sign x, sign y))+ let (x: u64) >>> (y: u64) = unsign (intrinsics.lshr64 (sign x, sign y)) let u8 (x: u8) = unsign (i64.u8 x) let u16 (x: u16) = unsign (i64.u16 x)@@ -737,19 +740,19 @@ let to_i32(x: u64) = intrinsics.zext_i64_i32 (sign x) let to_i64(x: u64) = intrinsics.zext_i64_i64 (sign x) - let (x: u64) == (y: u64) = intrinsics.eq_i64 (sign x) (sign y)- let (x: u64) < (y: u64) = intrinsics.ult64 (sign x) (sign y)- let (x: u64) > (y: u64) = intrinsics.ult64 (sign y) (sign x)- let (x: u64) <= (y: u64) = intrinsics.ule64 (sign x) (sign y)- let (x: u64) >= (y: u64) = intrinsics.ule64 (sign y) (sign x)+ let (x: u64) == (y: u64) = intrinsics.eq_i64 (sign x, sign y)+ let (x: u64) < (y: u64) = intrinsics.ult64 (sign x, sign y)+ let (x: u64) > (y: u64) = intrinsics.ult64 (sign y, sign x)+ let (x: u64) <= (y: u64) = intrinsics.ule64 (sign x, sign y)+ let (x: u64) >= (y: u64) = intrinsics.ule64 (sign y, sign x) let (x: u64) != (y: u64) = intrinsics.! (x == y) let sgn (x: u64) = unsign (intrinsics.usignum64 (sign x)) let abs (x: u64) = x let negate (x: t) = -x- let max (x: t) (y: t) = unsign (intrinsics.umax64 (sign x) (sign y))- let min (x: t) (y: t) = unsign (intrinsics.umin64 (sign x) (sign y))+ let max (x: t) (y: t) = unsign (intrinsics.umax64 (sign x, sign y))+ let min (x: t) (y: t) = unsign (intrinsics.umin64 (sign x, sign y)) let highest = 18446744073709551615u64 let lowest = highest + 1u64@@ -775,11 +778,12 @@ module i64m = i64 module u64m = u64 - let (x: f64) + (y: f64) = intrinsics.fadd64 x y- let (x: f64) - (y: f64) = intrinsics.fsub64 x y- let (x: f64) * (y: f64) = intrinsics.fmul64 x y- let (x: f64) / (y: f64) = intrinsics.fdiv64 x y- let (x: f64) ** (y: f64) = intrinsics.fpow64 x y+ let (x: f64) + (y: f64) = intrinsics.fadd64 (x, y)+ let (x: f64) - (y: f64) = intrinsics.fsub64 (x, y)+ let (x: f64) * (y: f64) = intrinsics.fmul64 (x, y)+ let (x: f64) / (y: f64) = intrinsics.fdiv64 (x, y)+ let (x: f64) % (y: f64) = intrinsics.fmod64 (x, y)+ let (x: f64) ** (y: f64) = intrinsics.fpow64 (x, y) let u8 (x: u8) = intrinsics.uitofp_i8_f64 (i8.u8 x) let u16 (x: u16) = intrinsics.uitofp_i16_f64 (i16.u16 x)@@ -801,16 +805,16 @@ let to_i64 (x: f64) = intrinsics.fptosi_f64_i64 x let to_f64 (x: f64) = x - let (x: f64) == (y: f64) = intrinsics.eq_f64 x y- let (x: f64) < (y: f64) = intrinsics.lt64 x y- let (x: f64) > (y: f64) = intrinsics.lt64 y x- let (x: f64) <= (y: f64) = intrinsics.le64 x y- let (x: f64) >= (y: f64) = intrinsics.le64 y x+ let (x: f64) == (y: f64) = intrinsics.eq_f64 (x, y)+ let (x: f64) < (y: f64) = intrinsics.lt64 (x, y)+ let (x: f64) > (y: f64) = intrinsics.lt64 (y, x)+ let (x: f64) <= (y: f64) = intrinsics.le64 (x, y)+ let (x: f64) >= (y: f64) = intrinsics.le64 (y, x) let (x: f64) != (y: f64) = intrinsics.! (x == y) let negate (x: t) = -x- let max (x: t) (y: t) = intrinsics.fmax64 x y- let min (x: t) (y: t) = intrinsics.fmin64 x y+ let max (x: t) (y: t) = intrinsics.fmax64 (x, y)+ let min (x: t) (y: t) = intrinsics.fmin64 (x, y) let sgn (x: f64) = if x < 0f64 then -1f64 else if x == 0f64 then 0f64@@ -829,24 +833,13 @@ let acos (x: f64) = intrinsics.acos64 x let asin (x: f64) = intrinsics.asin64 x let atan (x: f64) = intrinsics.atan64 x- let atan2 (x: f64) (y: f64) = intrinsics.atan2_64 x y+ let atan2 (x: f64) (y: f64) = intrinsics.atan2_64 (x, y) let gamma = intrinsics.gamma64 let lgamma = intrinsics.lgamma64-- let ceil (x: f64) : f64 =- let i = to_i64 x- let ix = i64 i- in if x >= 0.0 then- if ix < x then i64 (i i64m.+ 1i64) else x- else if ix > x then ix else x-- let floor (x: f64) : f64 =- let i = to_i64 x- let ix = i64 i- in if x >= 0.0 then- if ix < x then ix else x- else if ix > x then i64 (i i64m.- 1i64) else x+ let lerp v0 v1 t = intrinsics.lerp64 (v0, v1, t) + let ceil = intrinsics.ceil64+ let floor = intrinsics.floor64 let trunc (x: f64) : f64 = i64 (i64m.f64 x) let round = intrinsics.round64@@ -884,11 +877,12 @@ module u32m = u32 module f64m = f64 - let (x: f32) + (y: f32) = intrinsics.fadd32 x y- let (x: f32) - (y: f32) = intrinsics.fsub32 x y- let (x: f32) * (y: f32) = intrinsics.fmul32 x y- let (x: f32) / (y: f32) = intrinsics.fdiv32 x y- let (x: f32) ** (y: f32) = intrinsics.fpow32 x y+ let (x: f32) + (y: f32) = intrinsics.fadd32 (x, y)+ let (x: f32) - (y: f32) = intrinsics.fsub32 (x, y)+ let (x: f32) * (y: f32) = intrinsics.fmul32 (x, y)+ let (x: f32) / (y: f32) = intrinsics.fdiv32 (x, y)+ let (x: f32) % (y: f32) = intrinsics.fmod32 (x, y)+ let (x: f32) ** (y: f32) = intrinsics.fpow32 (x, y) let u8 (x: u8) = intrinsics.uitofp_i8_f32 (i8.u8 x) let u16 (x: u16) = intrinsics.uitofp_i16_f32 (i16.u16 x)@@ -910,16 +904,16 @@ let to_i64 (x: f32) = intrinsics.fptosi_f32_i64 x let to_f64 (x: f32) = intrinsics.fpconv_f32_f64 x - let (x: f32) == (y: f32) = intrinsics.eq_f32 x y- let (x: f32) < (y: f32) = intrinsics.lt32 x y- let (x: f32) > (y: f32) = intrinsics.lt32 y x- let (x: f32) <= (y: f32) = intrinsics.le32 x y- let (x: f32) >= (y: f32) = intrinsics.le32 y x+ let (x: f32) == (y: f32) = intrinsics.eq_f32 (x, y)+ let (x: f32) < (y: f32) = intrinsics.lt32 (x, y)+ let (x: f32) > (y: f32) = intrinsics.lt32 (y, x)+ let (x: f32) <= (y: f32) = intrinsics.le32 (x, y)+ let (x: f32) >= (y: f32) = intrinsics.le32 (y, x) let (x: f32) != (y: f32) = intrinsics.! (x == y) let negate (x: t) = -x- let max (x: t) (y: t) = intrinsics.fmax32 x y- let min (x: t) (y: t) = intrinsics.fmin32 x y+ let max (x: t) (y: t) = intrinsics.fmax32 (x, y)+ let min (x: t) (y: t) = intrinsics.fmin32 (x, y) let sgn (x: f32) = if x < 0f32 then -1f32 else if x == 0f32 then 0f32@@ -938,24 +932,13 @@ let acos (x: f32) = intrinsics.acos32 x let asin (x: f32) = intrinsics.asin32 x let atan (x: f32) = intrinsics.atan32 x- let atan2 (x: f32) (y: f32) = intrinsics.atan2_32 x y+ let atan2 (x: f32) (y: f32) = intrinsics.atan2_32 (x, y) let gamma = intrinsics.gamma32 let lgamma = intrinsics.lgamma32-- let ceil (x: f32) : f32 =- let i = to_i32 x- let ix = i32 i- in if x >= 0f32 then- if ix < x then i32 (i i32m.+ 1i32) else x- else if ix > x then ix else x-- let floor (x: f32) : f32 =- let i = to_i32 x- let ix = i32 i- in if x >= 0f32 then- if ix < x then ix else x- else if ix > x then i32 (i i32m.- 1i32) else x+ let lerp v0 v1 t = intrinsics.lerp32 (v0, v1, t) + let ceil = intrinsics.ceil32+ let floor = intrinsics.floor32 let trunc (x: f32) : f32 = i32 (i32m.f32 x) let round = intrinsics.round32
futlib/soacs.fut view
@@ -114,7 +114,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 =- intrinsics.gen_reduce (dest, f, ne, is, as)+ intrinsics.hist (1, dest, f, ne, is, as) -- | Inclusive prefix scan. Has the same caveats with respect to -- associativity as `reduce`.
package.yaml view
@@ -1,5 +1,5 @@ name: futhark-version: "0.12.1"+version: "0.12.2" synopsis: An optimising compiler for a functional, array-oriented language. description: | Futhark is a small programming language designed to be compiled to@@ -34,7 +34,7 @@ library: dependencies:- - base >= 4 && < 5+ - base >= 4.13 && < 5 - array >= 0.4 - binary >= 0.8.3 - data-binary-ieee754 >= 0.1@@ -79,6 +79,7 @@ - haskeline - utf8-string >= 1 - terminal-size >= 0.3+ - unordered-containers >= 0.2.7 build-tools: - alex
rts/csharp/scalar.cs view
@@ -310,6 +310,13 @@ private static float futhark_round32(float x){return (float) Math.Round(x);} private static double futhark_round64(double x){return Math.Round(x);}+private static float futhark_ceil32(float x){return (float) Math.Ceiling(x);}+private static double futhark_ceil64(double x){return Math.Ceiling(x);}+private static float futhark_floor32(float x){return (float) Math.Floor(x);}+private static double futhark_floor64(double x){return Math.Floor(x);}++private static float futhark_lerp32(float v0, float v1, float t){return v0 + (v1-v0)*t;}+private static double futhark_lerp64(double v0, double v1, double t){return v0 + (v1-v0)*t;} private static bool llt (bool x, bool y){return (!x && y);} private static bool lle (bool x, bool y){return (!x || y);}
+ rts/python/__init__.py view
rts/python/scalar.py view
@@ -305,6 +305,12 @@ def futhark_round64(x): return np.round(x) +def futhark_ceil64(x):+ return np.ceil(x)++def futhark_floor64(x):+ return np.floor(x)+ def futhark_isnan64(x): return np.isnan(x) @@ -364,6 +370,12 @@ def futhark_round32(x): return np.round(x) +def futhark_ceil32(x):+ return np.ceil(x)++def futhark_floor32(x):+ return np.floor(x)+ def futhark_isnan32(x): return np.isnan(x) @@ -377,5 +389,11 @@ def futhark_from_bits32(x): s = struct.pack('>l', x) return np.float32(struct.unpack('>f', s)[0])++def futhark_lerp32(v0, v1, t):+ return v0 + (v1-v0)*t++def futhark_lerp64(v0, v1, t):+ return v0 + (v1-v0)*t # End of scalar.py.
src/Futhark/Analysis/DataDependencies.hs view
@@ -54,7 +54,8 @@ -> M.Map VName Names -> Names findNecessaryForReturned usedAfterLoop merge_and_res allDependencies =- iterateNecessary mempty+ iterateNecessary mempty <>+ namesFromList (map paramName $ filter usedAfterLoop $ map fst merge_and_res) where iterateNecessary prev_necessary | necessary == prev_necessary = necessary | otherwise = iterateNecessary necessary
src/Futhark/Analysis/HORepresentation/SOAC.hs view
@@ -70,12 +70,11 @@ import Data.Foldable as Foldable import Data.Maybe-import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import qualified Futhark.Representation.AST as Futhark import Futhark.Representation.SOACS.SOAC- (StreamForm(..), ScremaForm(..), scremaType, getStreamAccums, GenReduceOp(..))+ (StreamForm(..), ScremaForm(..), scremaType, getStreamAccums, HistOp(..)) import qualified Futhark.Representation.SOACS.SOAC as Futhark import Futhark.Representation.AST hiding (Var, Iota, Rearrange, Reshape, Replicate, typeOf)@@ -361,7 +360,7 @@ data SOAC lore = Stream SubExp (StreamForm lore) (Lambda lore) [Input] | Scatter SubExp (Lambda lore) [Input] [(SubExp, Int, VName)] | Screma SubExp (ScremaForm lore) [Input]- | GenReduce SubExp [GenReduceOp lore] (Lambda lore) [Input]+ | Hist SubExp [HistOp lore] (Lambda lore) [Input] deriving (Eq, Show) instance PP.Pretty Input where@@ -379,8 +378,8 @@ instance PrettyLore lore => PP.Pretty (SOAC lore) where ppr (Screma w form arrs) = Futhark.ppScrema w form arrs- ppr (GenReduce len ops bucket_fun imgs) =- Futhark.ppGenReduce len ops bucket_fun imgs+ ppr (Hist len ops bucket_fun imgs) =+ Futhark.ppHist len ops bucket_fun imgs ppr soac = text $ show soac -- | Returns the inputs used in a SOAC.@@ -388,7 +387,7 @@ inputs (Stream _ _ _ arrs) = arrs inputs (Scatter _len _lam ivs _as) = ivs inputs (Screma _ _ arrs) = arrs-inputs (GenReduce _ _ _ inps) = inps+inputs (Hist _ _ _ inps) = inps -- | Set the inputs to a SOAC. setInputs :: [Input] -> SOAC lore -> SOAC lore@@ -398,8 +397,8 @@ Scatter (newWidth arrs w) lam arrs as setInputs arrs (Screma w form _) = Screma w form arrs-setInputs inps (GenReduce w ops lam _) =- GenReduce w ops lam inps+setInputs inps (Hist w ops lam _) =+ Hist w ops lam inps newWidth :: [Input] -> SubExp -> SubExp newWidth [] w = w@@ -410,7 +409,7 @@ lambda (Stream _ _ lam _) = lam lambda (Scatter _len lam _ivs _as) = lam lambda (Screma _ (ScremaForm _ _ lam) _) = lam-lambda (GenReduce _ _ lam _) = lam+lambda (Hist _ _ lam _) = lam -- | Set the lambda used in the SOAC. setLambda :: Lambda lore -> SOAC lore -> SOAC lore@@ -420,8 +419,8 @@ Scatter len lam ivs as setLambda lam (Screma w (ScremaForm scan red _) arrs) = Screma w (ScremaForm scan red lam) arrs-setLambda lam (GenReduce w ops _ inps) =- GenReduce w ops lam inps+setLambda lam (Hist w ops _ inps) =+ Hist w ops lam inps -- | The return type of a SOAC. typeOf :: SOAC lore -> [Type]@@ -438,9 +437,9 @@ (aws, _, _) = unzip3 dests typeOf (Screma w form _) = scremaType w form-typeOf (GenReduce _ ops _ _) = do+typeOf (Hist _ ops _ _) = do op <- ops- map (`arrayOfRow` genReduceWidth op) (lambdaReturnType $ genReduceOp op)+ map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op) -- | The "width" of a SOAC is the expected outer size of its array -- inputs _after_ input-transforms have been carried out.@@ -448,7 +447,7 @@ width (Stream w _ _ _) = w width (Scatter len _lam _ivs _as) = len width (Screma w _ _) = w-width (GenReduce w _ _ _) = w+width (Hist w _ _ _) = w -- | Convert a SOAC to the corresponding expression. toExp :: (MonadBinder m, Op (Lore m) ~ Futhark.SOAC (Lore m)) =>@@ -465,8 +464,8 @@ return $ Futhark.Scatter len lam ivs' dests toSOAC (Screma w form arrs) = Futhark.Screma w form <$> inputsToSubExps arrs-toSOAC (GenReduce w ops lam inps) =- Futhark.GenReduce w ops lam <$> inputsToSubExps inps+toSOAC (Hist w ops lam inps) =+ Futhark.Hist w ops lam <$> inputsToSubExps inps -- | The reason why some expression cannot be converted to a 'SOAC' -- value.@@ -492,8 +491,8 @@ return $ Right $ Scatter len lam ivs' as fromExp (Op (Futhark.Screma w form arrs)) = Right . Screma w form <$> traverse varInput arrs-fromExp (Op (Futhark.GenReduce w ops lam arrs)) =- Right . GenReduce w ops lam <$> traverse varInput arrs+fromExp (Op (Futhark.Hist w ops lam arrs)) =+ Right . Hist w ops lam <$> traverse varInput arrs fromExp _ = pure $ Left NotSOAC -- | To-Stream translation of SOACs.
src/Futhark/Analysis/PrimExp.hs view
@@ -147,6 +147,12 @@ fromInteger = fromInt32 . fromInteger +instance Pretty v => Fractional (PrimExp v) where+ x / y | Just z <- msum [asFloatOp FDiv x y] = constFoldPrimExp z+ | otherwise = numBad "/" (x,y)++ fromRational = ValueExp . FloatValue . Float64Value . fromRational+ instance Pretty v => IntegralExp (PrimExp v) where x `div` y | Just z <- msum [asIntOp SDiv x y, asFloatOp FDiv x y] = constFoldPrimExp z | otherwise = numBad "div" (x,y)@@ -248,7 +254,7 @@ -- | Evaluate a 'PrimExp' in the given monad. Invokes 'fail' on type -- errors.-evalPrimExp :: (Pretty v, Monad m) => (v -> m PrimValue) -> PrimExp v -> m PrimValue+evalPrimExp :: (Pretty v, MonadFail m) => (v -> m PrimValue) -> PrimExp v -> m PrimValue evalPrimExp f (LeafExp v _) = f v evalPrimExp _ (ValueExp v) = return v evalPrimExp f (BinOpExp op x y) = do@@ -270,7 +276,7 @@ maybe (evalBad h args) return $ do (_, _, fun) <- M.lookup h primFuns fun args' -evalBad :: (Pretty a, Pretty b, Monad m) => a -> b -> m c+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
src/Futhark/Analysis/ScalExp.hs view
@@ -14,7 +14,6 @@ import Data.List import Data.Maybe-import Data.Monoid ((<>)) import Futhark.Representation.Primitive hiding (SQuot, SRem, SDiv, SMod, SSignum) import Futhark.Representation.AST hiding (SQuot, SRem, SDiv, SMod, SSignum)
+ src/Futhark/Bench.hs view
@@ -0,0 +1,246 @@+{-# 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(..)+ )+ where++import Control.Applicative+import Control.Monad.Except+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 System.Exit+import System.IO+import System.IO.Temp (withSystemTempFile)+import System.Process.ByteString (readProcessWithExitCode)+import System.Timeout (timeout)++import Futhark.Test++newtype RunResult = RunResult { runMicroseconds :: Int }+ deriving (Eq, Show)+data DataResult = DataResult String (Either T.Text ([RunResult], T.Text))+ deriving (Eq, Show)+data BenchResult = BenchResult FilePath [DataResult]+ deriving (Eq, Show)++-- Intermediate types to help write the JSON instances.+newtype DataResults = DataResults { unDataResults :: [DataResult] }+newtype BenchResults = BenchResults { unBenchResults :: [BenchResult] }++instance JSON.ToJSON RunResult where+ toJSON = JSON.toJSON . runMicroseconds++instance JSON.FromJSON RunResult where+ parseJSON = fmap RunResult . JSON.parseJSON++instance JSON.ToJSON DataResults where+ toJSON (DataResults rs) =+ JSON.object $ map dataResultJSON rs+ toEncoding (DataResults rs) =+ JSON.pairs $ mconcat $ map (uncurry (JSON..=) . dataResultJSON) rs++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"++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)])++benchResultJSON :: BenchResult -> (T.Text, JSON.Value)+benchResultJSON (BenchResult prog r) =+ (T.pack prog,+ JSON.Object $ HM.singleton "datasets" (JSON.toJSON $ DataResults r))++instance JSON.ToJSON BenchResults where+ toJSON (BenchResults rs) =+ JSON.Object $ HM.fromList $ map benchResultJSON rs++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"++-- | Transform benchmark results to a JSON bytestring.+encodeBenchResults :: [BenchResult] -> LBS.ByteString+encodeBenchResults = JSON.encode . BenchResults++-- | Decode benchmark results from a JSON bytestring.+decodeBenchResults :: LBS.ByteString -> Either String [BenchResult]+decodeBenchResults = fmap unBenchResults . JSON.eitherDecode'++--- Running benchmarks++readRuntime :: T.Text -> Maybe Int+readRuntime s = case reads $ T.unpack s of+ [(runtime, _)] -> Just runtime+ _ -> 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++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+ let actualf = program `replaceExtension` "actual"+ 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)+ Nothing ->+ return ()++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+ 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)++-- | How to run a benchmark.+data RunOptions =+ RunOptions+ { runRunner :: String+ , runRuns :: Int+ , runExtraOptions :: [String]+ , runTimeout :: Int+ }++-- | 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 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"]++ -- 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)++ 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++ 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+ }++progNotFound :: String -> String+progNotFound s = s ++ ": command not found"++-- | Compile and produce reference datasets.+prepareBenchmarkProgram :: MonadIO m =>+ CompileOptions+ -> FilePath+ -> [InputOutputs]+ -> m (Either (String, Maybe SBS.ByteString) ())+prepareBenchmarkProgram opts program cases = do+ let futhark = compFuthark opts++ ref_res <- runExceptT $ ensureReferenceOutput 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)++ Right () -> do+ (futcode, _, futerr) <- liftIO $ readProcessWithExitCode futhark+ [compBackend opts, program, "-o", binaryName program] ""++ case futcode of+ ExitSuccess -> return $ Right ()+ ExitFailure 127 -> return $ Left (progNotFound futhark, Nothing)+ ExitFailure _ -> return $ Left ("Compilation of " ++ program ++ " failed:\n", Just futerr)
src/Futhark/Binder/Class.hs view
@@ -22,6 +22,7 @@ import Control.Monad.Writer import qualified Control.Monad.Fail as Fail+import qualified Data.Kind import Futhark.Representation.AST import Futhark.MonadFreshNames@@ -59,7 +60,7 @@ LocalScope (Lore m) m, Fail.MonadFail m) => MonadBinder m where- type Lore m :: *+ type Lore m :: Data.Kind.Type mkExpAttrM :: Pattern (Lore m) -> Exp (Lore m) -> m (ExpAttr (Lore m)) mkBodyM :: Stms (Lore m) -> Result -> m (Body (Lore m)) mkLetNamesM :: [VName] -> Exp (Lore m) -> m (Stm (Lore m))
+ src/Futhark/CLI/Autotune.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Futhark.CLI.Autotune (main) where++import Control.Monad+import qualified Data.ByteString.Char8 as SBS+import Data.Time.Clock.POSIX+import Data.Tree+import Data.List+import Data.Maybe+import Text.Read (readMaybe)+import Text.Regex.TDFA+import qualified Data.Text as T++import System.Environment (getExecutablePath)+import System.Exit+import System.Process+import System.FilePath+import System.Console.GetOpt++import Futhark.Bench+import Futhark.Test+import Futhark.Util.Options++data AutotuneOptions = AutotuneOptions+ { optBackend :: String+ , optFuthark :: Maybe String+ , optRuns :: Int+ , optTuning :: Maybe String+ , optExtraOptions :: [String]+ , optVerbose :: Int+ }++initialAutotuneOptions :: AutotuneOptions+initialAutotuneOptions = AutotuneOptions "opencl" Nothing 10 (Just "tuning") [] 0++compileOptions :: AutotuneOptions -> IO CompileOptions+compileOptions opts = do+ futhark <- maybe getExecutablePath return $ optFuthark opts+ return $ CompileOptions { compFuthark = futhark+ , compBackend = optBackend opts }++runOptions :: Path -> Int -> AutotuneOptions -> RunOptions+runOptions path timeout_s opts =+ RunOptions { runRunner = ""+ , runRuns = optRuns opts+ , runExtraOptions = "-L" : map opt path ++ optExtraOptions opts+ , runTimeout = timeout_s+ }+ where opt (name, val) = "--size=" ++ name ++ "=" ++ show val++type Path = [(String, Int)]++regexGroups :: Regex -> String -> Maybe [String]+regexGroups regex s = do+ (_, _, _, groups) <- matchM regex s :: Maybe (String, String, String, [String])+ Just groups++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')+++data RunPurpose = RunSample -- ^ Only a single run.+ | RunBenchmark -- ^ As many runs as needed.++type RunDataset = Path -> RunPurpose -> IO (Either String ([(String, Int)], Double))++type DatasetName = String++prepare :: AutotuneOptions -> FilePath -> IO [(DatasetName, RunDataset)]+prepare opts prog = do+ spec <- testSpecFromFile prog+ copts <- compileOptions opts++ truns <-+ case testAction spec of+ RunCases ios _ _+ | Just runs <- iosTestRuns <$> find ((=="main") . iosEntryPoint) ios -> do+ res <- prepareBenchmarkProgram copts prog ios+ case res of+ Left (err, errstr) -> do+ putStrLn err+ maybe (return ()) SBS.putStrLn errstr+ exitFailure+ Right () ->+ return runs+ _ ->+ fail "Program does not have a 'main' entry point with datasets."++ let runnableDataset trun =+ case runExpectedResult trun of+ Succeeds expected+ | null (runTags trun `intersect` ["notune", "disable"]) ->+ Just (runDescription trun, run trun expected)++ _ -> Nothing++ -- We wish to let datasets run for the untuned time + 20% + 1 second.+ let timeout elapsed = ceiling (elapsed * 1.2) + 1++ forM (mapMaybe runnableDataset truns) $ \(dataset, do_run) -> do+ bef <- toRational <$> getPOSIXTime+ res <- do_run 60000 [] RunBenchmark+ aft <- toRational <$> getPOSIXTime+ case res of Left err -> do+ putStrLn $ "Error when running " ++ prog ++ ":"+ putStrLn err+ exitFailure+ Right _ -> do+ let t = timeout $ aft - bef+ putStrLn $ "Calculated timeout for " ++ dataset ++ " : " ++ show t ++ "s"+ return (dataset, do_run t)++ where run trun expected timeout path purpose = do+ let opts' = case purpose of RunSample -> opts { optRuns = 1 }+ RunBenchmark -> opts++ averageRuntime (runres, errout) =+ (comparisons (T.unpack errout),+ fromIntegral (sum (map runMicroseconds runres)) /+ fromIntegral (optRuns opts))++ ropts = runOptions path timeout opts'++ when (optVerbose opts > 1) $+ putStrLn $ "Running with options: " ++ unwords (runExtraOptions ropts)++ either (Left . T.unpack) (Right . averageRuntime) <$>+ benchmarkDataset ropts prog "main"+ (runInput trun) expected+ (testRunReferenceOutput prog "main" trun)++--- Benchmarking a program++data DatasetResult = DatasetResult [(String, Int)] Double+ deriving Show++--- Finding initial comparisons.++--- Extracting threshold hierarchy.++type ThresholdForest = Forest (String, Bool)++thresholdMin, thresholdMax :: Int+thresholdMin = 1+thresholdMax = 2000000000++-- | Depth-first list of thresholds to tune in order, and a+-- corresponding assignment of ancestor thresholds to ensure that they+-- are used.+tuningPaths :: ThresholdForest -> [(String, Path)]+tuningPaths = concatMap (treePaths [])+ 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++ t False = thresholdMax+ t True = thresholdMin++thresholdForest :: FilePath -> IO ThresholdForest+thresholdForest prog = do+ 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)++ unfold thresholds ((parent, parent_cmp), ancestors) =+ let ancestors' = parent : ancestors++ 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++intersectRanges :: [(Int, Int)] -> (Int, Int)+intersectRanges = foldl' f (thresholdMin, thresholdMax)+ where f (xmin, xmax) (ymin, ymax) =+ -- XXX: what happens when the intersection is empty?+ (xmin `max` ymin,+ xmax `min` ymax)++tuneThreshold :: AutotuneOptions+ -> [(DatasetName, RunDataset)]+ -> Path -> (String, Path)+ -> IO Path+tuneThreshold opts datasets already_tuned (v, v_path) = do+ ranges <-+ forM datasets $ \(dataset_name, run) -> do++ putStrLn $ unwords ["Tuning", v, "on dataset", dataset_name]++ sample_run <- run path RunSample++ 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 (thresholdMin, thresholdMax)+ Right (cmps, _) ->+ case lookup v cmps of+ Nothing -> do+ -- A missing comparison is not necessarily a bug - it may+ -- simply mean that this comparison is inside a loop or+ -- branch that is never reached for this dataset. In such+ -- cases, the optimal range is universal.+ when (optVerbose opts > 0) $ putStrLn "Irrelevant for dataset.\n"+ return (thresholdMin, thresholdMax)+ Just e_par -> do+ t_run <- run path_t RunBenchmark+ f_run <- run path_f RunBenchmark++ let prefer_t = (thresholdMin, e_par)+ prefer_f = (e_par+1, thresholdMax)++ case (t_run, f_run) of+ (Left err, _) -> do+ when (optVerbose opts > 0) $ putStrLn $ "True comparison run failed:\n" ++ err+ return prefer_f+ (_, Left err) -> do+ when (optVerbose opts > 0) $ putStrLn $ "False comparison run failed:\n" ++ err+ return prefer_t+ (Right (_, runtime_t), Right (_, runtime_f)) ->+ if runtime_t < runtime_f+ then do when (optVerbose opts > 0) $ putStrLn "True branch is fastest."+ return prefer_t+ else do when (optVerbose opts > 0) $ putStrLn "False branch is fastest."+ return prefer_f++ let (_lower, upper) = intersectRanges ranges+ return $ (v,upper) : already_tuned++ where path = already_tuned ++ v_path+ path_t = (v, thresholdMin) : path+ path_f = (v, thresholdMax) : path++--- CLI++tune :: AutotuneOptions -> FilePath -> IO Path+tune opts prog = do+ putStrLn $ "Compiling " ++ prog ++ "..."+ datasets <- prepare opts prog++ forest <- thresholdForest prog+ when (optVerbose opts > 0) $+ putStrLn $ ("Threshold forest:\n"++) $ drawForest $ map (fmap show) forest++ foldM (tuneThreshold opts datasets) [] $ tuningPaths forest++runAutotuner :: AutotuneOptions -> FilePath -> IO ()+runAutotuner opts prog = do+ best <- tune opts prog++ let tuning = unlines $ do (s, n) <- sortOn fst best+ return $ s ++ "=" ++ show n++ case optTuning opts of+ Nothing -> return ()+ Just suffix -> do+ writeFile (prog <.> suffix) tuning+ putStrLn $ "Wrote " ++ prog <.> suffix++ putStrLn $ "Result of autotuning:\n" ++ tuning++commandLineOptions :: [FunOptDescr AutotuneOptions]+commandLineOptions = [+ Option "r" ["runs"]+ (ReqArg (\n ->+ case reads n of+ [(n', "")] | n' >= 0 ->+ Right $ \config ->+ 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 [] ["tuning"]+ (ReqArg (\s -> Right $ \config -> config { optTuning = Just s })+ "EXTENSION")+ "Write tuning files with this extension (default: .tuning)."+ , Option "v" ["verbose"]+ (NoArg $ Right $ \config -> config { optVerbose = optVerbose config + 1 })+ "Enable logging. Pass multiple times for more."+ ]++main :: String -> [String] -> IO ()+main = mainWithOptions initialAutotuneOptions commandLineOptions+ "options... program" $+ \progs config ->+ case progs of [prog] -> Just $ runAutotuner config prog+ _ -> Nothing
src/Futhark/CLI/Bench.hs view
@@ -3,33 +3,25 @@ {-# LANGUAGE FlexibleContexts #-} -- | Simple tool for benchmarking Futhark programs. Use the @--json@ -- flag for machine-readable output.-module Futhark.CLI.Bench (main) where+module Futhark.CLI.Bench ( main ) where import Control.Monad import Control.Monad.Except import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS-import qualified Data.Map as M import Data.Either import Data.Maybe import Data.List import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Encoding as T import System.Console.GetOpt-import System.FilePath import System.Directory import System.Environment import System.IO-import System.IO.Temp-import System.Timeout-import System.Process.ByteString (readProcessWithExitCode) import System.Exit-import qualified Data.Aeson as JSON-import qualified Data.Aeson.Encoding.Internal as JSON import Text.Printf import Text.Regex.TDFA +import Futhark.Bench import Futhark.Test import Futhark.Util (pmapIO) import Futhark.Util.Options@@ -53,37 +45,6 @@ initialBenchOptions = BenchOptions "c" Nothing "" 10 [] Nothing (-1) False ["nobench", "disable"] [] Nothing (Just "tuning") --- | The name we use for compiled programs.-binaryName :: FilePath -> FilePath-binaryName = dropExtension--newtype RunResult = RunResult { runMicroseconds :: Int }-data DataResult = DataResult String (Either T.Text ([RunResult], T.Text))-data BenchResult = BenchResult FilePath [DataResult]---- Intermediate types to help write the JSON instances.-newtype DataResults = DataResults [DataResult]--instance JSON.ToJSON DataResults where- toJSON (DataResults rs) =- JSON.object $ map dataResultJSON rs- toEncoding (DataResults rs) =- JSON.pairs $ mconcat $ map (uncurry (JSON..=) . dataResultJSON) rs--dataResultJSON :: DataResult -> (T.Text, JSON.Value)-dataResultJSON (DataResult desc (Left err)) =- (T.pack desc, JSON.toJSON $ show err)-dataResultJSON (DataResult desc (Right (runtimes, progerr))) =- (T.pack desc, JSON.object- [("runtimes", JSON.toJSON $ map runMicroseconds runtimes),- ("stderr", JSON.toJSON progerr)])--encodeBenchResults :: [BenchResult] -> LBS.ByteString-encodeBenchResults rs =- JSON.encodingToLazyByteString $ JSON.pairs $ mconcat $ do- BenchResult prog r <- rs- return $ T.pack prog JSON..= M.singleton ("datasets" :: T.Text) (DataResults r)- runBenchmarks :: BenchOptions -> [FilePath] -> IO () runBenchmarks opts paths = do -- We force line buffering to ensure that we produce running output.@@ -114,9 +75,15 @@ anyFailedToCompile :: [SkipReason] -> Bool anyFailedToCompile = not . all (==Skipped) -data SkipReason = Skipped | FailedToCompile | ReferenceFailed+data SkipReason = Skipped | FailedToCompile deriving (Eq) +compileOptions :: BenchOptions -> IO CompileOptions+compileOptions opts = do+ futhark <- maybe getExecutablePath return $ optFuthark opts+ return $ CompileOptions { compFuthark = futhark+ , compBackend = optBackend opts }+ compileBenchmark :: BenchOptions -> (FilePath, ProgramTest) -> IO (Either SkipReason (FilePath, [InputOutputs])) compileBenchmark opts (program, spec) =@@ -132,28 +99,21 @@ else do putStrLn $ binaryName program ++ " does not exist, but --skip-compilation passed." return $ Left FailedToCompile else do+ putStr $ "Compiling " ++ program ++ "...\n" - futhark <- maybe getExecutablePath return $ optFuthark opts+ compile_opts <- compileOptions opts - ref_res <- runExceptT $ ensureReferenceOutput futhark "c" program cases- case ref_res of- Left err -> do- putStrLn "Reference output generation failed:\n"- print err- return $ Left ReferenceFailed+ res <- prepareBenchmarkProgram compile_opts program cases - Right () -> do- (futcode, _, futerr) <- liftIO $ readProcessWithExitCode futhark- [optBackend opts, program, "-o", binaryName program] ""+ case res of+ Left (err, errstr) -> do+ putStrLn err+ maybe (return ()) SBS.putStrLn errstr+ return $ Left FailedToCompile+ Right () ->+ return $ Right (program, cases) - case futcode of- ExitSuccess -> return $ Right (program, cases)- ExitFailure 127 -> do putStrLn $ "Failed:\n" ++ progNotFound futhark- return $ Left FailedToCompile- ExitFailure _ -> do putStrLn "Failed:\n"- SBS.putStrLn futerr- return $ Left FailedToCompile _ -> return $ Left Skipped where hasRuns (InputOutputs _ runs) = not $ null runs@@ -186,16 +146,12 @@ putStrLn $ printf "%10.2f" avg ++ "μs (avg. of " ++ show (length runtimes) ++ " runs; RSD: " ++ printf "%.2f" rel_dev ++ ")" -progNotFound :: String -> String-progNotFound s = s ++ ": command not found"--type BenchM = ExceptT T.Text IO--runBenchM :: BenchM a -> IO (Either T.Text a)-runBenchM = runExceptT--io :: IO a -> BenchM a-io = liftIO+runOptions :: BenchOptions -> RunOptions+runOptions opts = RunOptions { runRunner = optRunner opts+ , runRuns = optRuns opts+ , runExtraOptions = optExtraOptions opts+ , runTimeout = optTimeout opts+ } runBenchmarkCase :: BenchOptions -> FilePath -> T.Text -> Int -> TestRun -> IO (Maybe DataResult)@@ -204,112 +160,22 @@ runBenchmarkCase opts _ _ _ (TestRun tags _ _ _ _) | any (`elem` tags) $ optExcludeCase opts = return Nothing-runBenchmarkCase opts program entry pad_to tr@(TestRun _ input_spec (Succeeds expected_spec) _ dataset_desc) =- -- 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 $- testRunReferenceOutput program entry tr- maybe_expected <- maybe (return Nothing) (fmap Just . getValuesAndBS) expected_spec- let options = optExtraOptions opts ++ ["-e", T.unpack entry,- "-t", tmpfile,- "-r", show $ optRuns opts,- "-b"]-+runBenchmarkCase opts program entry pad_to tr@(TestRun _ input_spec (Succeeds expected_spec) _ dataset_desc) = do -- Report the dataset name before running the program, so that if an -- error occurs it's easier to see where. putStr $ "dataset " ++ dataset_desc ++ ": " ++ replicate (pad_to - length dataset_desc) ' ' hFlush stdout - -- 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 $ optRunner opts = ("." </> binaryName program, options)- | otherwise = (optRunner opts, binaryName program : options)-- run_res <-- timeout (optTimeout opts * 1000000) $- readProcessWithExitCode to_run to_run_args $- LBS.toStrict input-- fmap (Just . DataResult dataset_desc) $ runBenchM $ 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 <- io $ T.readFile tmpfile- runtimes <- case mapM readRuntime $ T.lines runtime_result of- Just runtimes -> return $ map RunResult runtimes- Nothing -> itWentWrong $ "Runtime file has invalid contents:\n" <> runtime_result-- io $ reportResult runtimes- return (runtimes, T.decodeUtf8 progerr)- Nothing ->- itWentWrong $ T.pack $ "Execution exceeded " ++ show (optTimeout opts) ++ " seconds."-- where dir = takeDirectory program---readRuntime :: T.Text -> Maybe Int-readRuntime s = case reads $ T.unpack s of- [(runtime, _)] -> Just runtime- _ -> Nothing--didNotFail :: FilePath -> ExitCode -> T.Text -> BenchM ()-didNotFail _ ExitSuccess _ =- return ()-didNotFail program (ExitFailure code) stderr_s =- itWentWrong $ T.pack $ program ++ " failed with error code " ++ show code ++- " and output:\n" ++ T.unpack stderr_s--itWentWrong :: (MonadError T.Text m, MonadIO m) =>- T.Text -> m a-itWentWrong t = do- liftIO $ putStrLn $ T.unpack t- throwError t--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- let actualf = program `replaceExtension` "actual"- liftIO $ SBS.writeFile actualf stdout_s- itWentWrong $ T.pack $ show e <> "\n(See " <> actualf <> ")"- Right vs -> return (stdout_s, vs)-runResult program (ExitFailure code) _ stderr_s =- itWentWrong $ T.pack $ program ++ " failed with error code " ++ show code ++- " and output:\n" ++ T.unpack (T.decodeUtf8 stderr_s)--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- let actualf = program `replaceExtension` "actual"- expectedf = program `replaceExtension` "expected"- liftIO $ SBS.writeFile actualf actual_bs- liftIO $ SBS.writeFile expectedf expected_bs- itWentWrong $ T.pack actualf <> " and " <> T.pack expectedf <>- " do not match:\n" <> T.pack (show mismatch)- Nothing ->- return ()+ res <- benchmarkDataset (runOptions opts) program entry input_spec expected_spec+ (testRunReferenceOutput program entry tr)+ case res of+ Left err -> do+ liftIO $ putStrLn $ T.unpack err+ return $ Just $ DataResult dataset_desc $ Left err+ Right (runtimes, errout) -> do+ reportResult runtimes+ return $ Just $ DataResult dataset_desc $ Right (runtimes, errout) commandLineOptions :: [FunOptDescr BenchOptions] commandLineOptions = [@@ -378,7 +244,7 @@ , Option [] ["tuning"] (ReqArg (\s -> Right $ \config -> config { optTuning = Just s }) "EXTENSION")- "Look for tuning files with this extension (defaults: .tuning)."+ "Look for tuning files with this extension (defaults to .tuning)." , Option [] ["no-tuning"] (NoArg $ Right $ \config -> config { optTuning = Nothing }) "Do not load tuning files."
src/Futhark/CLI/Doc.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} module Futhark.CLI.Doc (main) where -import Control.Monad.IO.Class (liftIO) import Control.Monad.State import Data.FileEmbed import Data.List
src/Futhark/CLI/Misc.hs view
@@ -3,17 +3,22 @@ module Futhark.CLI.Misc ( mainCheck , mainImports+ , mainDataget ) where -import Data.List (isPrefixOf)+import qualified Data.ByteString.Lazy as BS+import Data.List (isPrefixOf, isInfixOf, nubBy)+import Data.Function (on) import Control.Monad.State+import System.FilePath import System.IO import System.Exit import Futhark.Compiler import Futhark.Util.Options import Futhark.Pipeline+import Futhark.Test runFutharkM' :: FutharkM () -> IO () runFutharkM' m = do@@ -42,3 +47,33 @@ liftIO $ putStr $ unlines $ map (++ ".fut") $ filter (\f -> not ("futlib/" `isPrefixOf` f)) $ map fst prog_imports++mainDataget :: String -> [String] -> IO ()+mainDataget = mainWithOptions () [] "program dataset" $ \args () ->+ case args of+ [file, dataset] -> Just $ dataget file dataset+ _ -> Nothing+ where dataget prog dataset = do+ let dir = takeDirectory prog++ runs <- testSpecRuns <$> testSpecFromFile prog++ let exact = filter ((dataset==) . runDescription) runs+ infixes = filter ((dataset `isInfixOf`) . runDescription) runs++ case nubBy ((==) `on` runDescription) $+ if null exact then infixes else exact of+ [x] -> BS.putStr =<< getValuesBS dir (runInput x)++ [] -> do hPutStr stderr $ "No dataset '" ++ dataset ++ "'.\n"+ hPutStr stderr "Available datasets:\n"+ mapM_ (hPutStrLn stderr . (" "++) . runDescription) runs+ exitFailure++ runs' -> do hPutStr stderr $ "Dataset '" ++ dataset ++ "' ambiguous:\n"+ mapM_ (hPutStrLn stderr . (" "++) . runDescription) runs'+ exitFailure++ testSpecRuns = testActionRuns . testAction+ testActionRuns CompileTimeFailure{} = []+ testActionRuns (RunCases ios _ _) = concatMap iosTestRuns ios
src/Futhark/CLI/Pkg.hs view
@@ -172,6 +172,8 @@ instance Monad PkgM where PkgM m >>= f = PkgM $ m >>= unPkgM . f return = PkgM . return++instance MonadFail PkgM where fail s = liftIO $ do prog <- getProgName putStrLn $ prog ++ ": " ++ s
src/Futhark/CodeGen/Backends/CCUDA.hs view
@@ -88,6 +88,26 @@ exit(0); }|] }+ , Option { optionLongName = "default-group-size"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "INT"+ , optionAction = [C.cstm|futhark_context_config_set_default_group_size(cfg, atoi(optarg));|]+ }+ , Option { optionLongName = "default-num-groups"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "INT"+ , optionAction = [C.cstm|futhark_context_config_set_default_num_groups(cfg, atoi(optarg));|]+ }+ , Option { optionLongName = "default-tile-size"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "INT"+ , optionAction = [C.cstm|futhark_context_config_set_default_tile_size(cfg, atoi(optarg));|]+ }+ , Option { optionLongName = "default-threshold"+ , optionShortName = Nothing+ , optionArgument = RequiredArgument "INT"+ , optionAction = [C.cstm|futhark_context_config_set_default_threshold(cfg, atoi(optarg));|]+ } , Option { optionLongName = "tuning" , optionShortName = Nothing , optionArgument = RequiredArgument "FILE"@@ -111,7 +131,7 @@ sizeof($ty:t))); }|] writeCUDAScalar _ _ _ space _ _ =- fail $ "Cannot write to '" ++ space ++ "' memory space."+ error $ "Cannot write to '" ++ space ++ "' memory space." readCUDAScalar :: GC.ReadScalar OpenCL () readCUDAScalar mem idx t "device" _ = do@@ -124,19 +144,19 @@ |] return [C.cexp|$id:val|] readCUDAScalar _ _ _ space _ =- fail $ "Cannot write to '" ++ space ++ "' memory space."+ error $ "Cannot write to '" ++ space ++ "' memory space." allocateCUDABuffer :: GC.Allocate OpenCL () allocateCUDABuffer mem size tag "device" = GC.stm [C.cstm|CUDA_SUCCEED(cuda_alloc(&ctx->cuda, $exp:size, $exp:tag, &$exp:mem));|] allocateCUDABuffer _ _ _ space =- fail $ "Cannot allocate in '" ++ space ++ "' memory space."+ error $ "Cannot allocate in '" ++ space ++ "' memory space." deallocateCUDABuffer :: GC.Deallocate OpenCL () deallocateCUDABuffer mem tag "device" = GC.stm [C.cstm|CUDA_SUCCEED(cuda_free(&ctx->cuda, $exp:mem, $exp:tag));|] deallocateCUDABuffer _ _ space =- fail $ "Cannot deallocate in '" ++ space ++ "' memory space."+ error $ "Cannot deallocate in '" ++ space ++ "' memory space." copyCUDAMemory :: GC.Copy OpenCL () copyCUDAMemory dstmem dstidx dstSpace srcmem srcidx srcSpace nbytes = do@@ -150,7 +170,7 @@ memcpyFun DefaultSpace (Space "device") = return "cuMemcpyDtoH" memcpyFun (Space "device") DefaultSpace = return "cuMemcpyHtoD" memcpyFun (Space "device") (Space "device") = return "cuMemcpy"- memcpyFun _ _ = fail $ "Cannot copy to '" ++ show dstSpace+ memcpyFun _ _ = error $ "Cannot copy to '" ++ show dstSpace ++ "' from '" ++ show srcSpace ++ "'." staticCUDAArray :: GC.StaticArray OpenCL ()@@ -180,13 +200,13 @@ }|] GC.item [C.citem|struct memblock_device $id:name = ctx->$id:name;|] staticCUDAArray _ space _ _ =- fail $ "CUDA backend cannot create static array in '" ++ space+ error $ "CUDA backend cannot create static array in '" ++ space ++ "' memory space" cudaMemoryType :: GC.MemoryType OpenCL () cudaMemoryType "device" = return [C.cty|typename CUdeviceptr|] cudaMemoryType space =- fail $ "CUDA backend does not support '" ++ space ++ "' memory space."+ error $ "CUDA backend does not support '" ++ space ++ "' memory space." callKernel :: GC.OpCompiler OpenCL () callKernel (HostCode c) = GC.compileCode c
src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs view
@@ -159,17 +159,18 @@ cfg->cu_cfg.load_ptx_from = path; }|]) - GC.publicDef_ "context_config_set_default_block_size" GC.InitDecl $ \s ->+ GC.publicDef_ "context_config_set_default_group_size" GC.InitDecl $ \s -> ([C.cedecl|void $id:s(struct $id:cfg* cfg, int size);|], [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { cfg->cu_cfg.default_block_size = size; cfg->cu_cfg.default_block_size_changed = 1; }|]) - GC.publicDef_ "context_config_set_default_grid_size" GC.InitDecl $ \s ->+ GC.publicDef_ "context_config_set_default_num_groups" GC.InitDecl $ \s -> ([C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], [C.cedecl|void $id:s(struct $id:cfg* cfg, int num) { cfg->cu_cfg.default_grid_size = num;+ cfg->cu_cfg.default_grid_size_changed = 1; }|]) GC.publicDef_ "context_config_set_default_tile_size" GC.InitDecl $ \s ->@@ -196,12 +197,12 @@ } } - if (strcmp(size_name, "default_block_size") == 0) {+ if (strcmp(size_name, "default_group_size") == 0) { cfg->cu_cfg.default_block_size = size_value; return 0; } - if (strcmp(size_name, "default_grid_size") == 0) {+ if (strcmp(size_name, "default_num_groups") == 0) { cfg->cu_cfg.default_grid_size = size_value; return 0; }
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -171,7 +171,7 @@ 0, NULL, NULL)); }|] writeOpenCLScalar _ _ _ space _ _ =- fail $ "Cannot write to '" ++ space ++ "' memory space."+ error $ "Cannot write to '" ++ space ++ "' memory space." readOpenCLScalar :: GC.ReadScalar OpenCL () readOpenCLScalar mem i t "device" _ = do@@ -185,19 +185,19 @@ |] return [C.cexp|$id:val|] readOpenCLScalar _ _ _ space _ =- fail $ "Cannot read from '" ++ space ++ "' memory space."+ error $ "Cannot read from '" ++ space ++ "' memory space." allocateOpenCLBuffer :: GC.Allocate OpenCL () allocateOpenCLBuffer mem size tag "device" = GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_alloc(&ctx->opencl, $exp:size, $exp:tag, &$exp:mem));|] allocateOpenCLBuffer _ _ _ space =- fail $ "Cannot allocate in '" ++ space ++ "' space."+ error $ "Cannot allocate in '" ++ space ++ "' space." deallocateOpenCLBuffer :: GC.Deallocate OpenCL () deallocateOpenCLBuffer mem tag "device" = GC.stm [C.cstm|OPENCL_SUCCEED_OR_RETURN(opencl_free(&ctx->opencl, $exp:mem, $exp:tag));|] deallocateOpenCLBuffer _ _ space =- fail $ "Cannot deallocate in '" ++ space ++ "' space"+ error $ "Cannot deallocate in '" ++ space ++ "' space" copyOpenCLMemory :: GC.Copy OpenCL ()@@ -248,7 +248,7 @@ openclMemoryType :: GC.MemoryType OpenCL () openclMemoryType "device" = pure [C.cty|typename cl_mem|] openclMemoryType space =- fail $ "OpenCL backend does not support '" ++ space ++ "' memory space."+ error $ "OpenCL backend does not support '" ++ space ++ "' memory space." staticOpenCLArray :: GC.StaticArray OpenCL () staticOpenCLArray name "device" t vs = do@@ -285,7 +285,7 @@ GC.item [C.citem|struct memblock_device $id:name = ctx->$id:name;|] staticOpenCLArray _ space _ _ =- fail $ "OpenCL backend cannot create static array in memory space '" ++ space ++ "'"+ error $ "OpenCL backend cannot create static array in memory space '" ++ space ++ "'" callKernel :: GC.OpCompiler OpenCL () callKernel (GetSize v key) =@@ -306,7 +306,8 @@ zipWithM_ setKernelArg [(0::Int)..] args num_workgroups' <- mapM GC.compileExp num_workgroups workgroup_size' <- mapM GC.compileExp workgroup_size- launchKernel name num_workgroups' workgroup_size'+ local_bytes <- foldM localBytes [C.cexp|0|] args+ launchKernel name num_workgroups' workgroup_size' local_bytes where setKernelArg i (ValueKArg e bt) = do v <- GC.compileExpToName "kernel_arg" bt e GC.stm [C.cstm|@@ -325,9 +326,14 @@ OPENCL_SUCCEED_OR_RETURN(clSetKernelArg(ctx->$id:name, $int:i, $exp:num_bytes', NULL)); |] + localBytes cur (SharedMemoryKArg num_bytes) = do+ num_bytes' <- GC.compileExp $ unCount num_bytes+ return [C.cexp|$exp:cur + $exp:num_bytes'|]+ localBytes cur _ = return cur+ launchKernel :: C.ToExp a =>- String -> [a] -> [a] -> GC.CompilerM op s ()-launchKernel kernel_name num_workgroups workgroup_dims = do+ String -> [a] -> [a] -> a -> GC.CompilerM op s ()+launchKernel kernel_name num_workgroups workgroup_dims local_bytes = do global_work_size <- newVName "global_work_size" time_start <- newVName "time_start" time_end <- newVName "time_end"@@ -344,7 +350,7 @@ $stms:(printKernelSize global_work_size) fprintf(stderr, "] and local work size ["); $stms:(printKernelSize local_work_size)- fprintf(stderr, "].\n");+ fprintf(stderr, "]; local memory parameters sum to %d bytes.\n", (int)$exp:local_bytes); $id:time_start = get_wall_time(); } OPENCL_SUCCEED_OR_RETURN(
src/Futhark/CodeGen/Backends/CSOpenCL.hs view
@@ -16,7 +16,6 @@ import Futhark.CodeGen.Backends.GenericCSharp.AST import Futhark.CodeGen.Backends.GenericCSharp.Options import Futhark.CodeGen.Backends.GenericCSharp.Definitions-import Futhark.Util.Pretty(pretty) import Futhark.Util (zEncodeString) import Futhark.MonadFreshNames hiding (newVName') @@ -265,7 +264,7 @@ ] writeOpenCLScalar _ _ _ space _ =- fail $ "Cannot write to '" ++ space ++ "' memory space."+ error $ "Cannot write to '" ++ space ++ "' memory space." readOpenCLScalar :: CS.ReadScalar Imp.OpenCL () readOpenCLScalar mem i bt "device" = do@@ -284,7 +283,7 @@ return $ Var val readOpenCLScalar _ _ _ space =- fail $ "Cannot read from '" ++ space ++ "' memory space."+ error $ "Cannot read from '" ++ space ++ "' memory space." computeErrCodeT :: CSType computeErrCodeT = CustomT "ComputeErrorCode"@@ -297,7 +296,7 @@ CS.stm $ Reassign (Var mem') (CS.simpleCall "MemblockAllocDevice" [Ref $ Var "Ctx", Var mem', size, String mem']) allocateOpenCLBuffer _ _ space =- fail $ "Cannot allocate in '" ++ space ++ "' space"+ error $ "Cannot allocate in '" ++ space ++ "' space" copyOpenCLMemory :: CS.Copy Imp.OpenCL () copyOpenCLMemory destmem destidx Imp.DefaultSpace srcmem srcidx (Imp.Space "device") nbytes _ = do@@ -373,7 +372,7 @@ ] staticOpenCLArray _ space _ _ =- fail $ "CSOpenCL backend cannot create static array in memory space '" ++ space ++ "'"+ error $ "CSOpenCL backend cannot create static array in memory space '" ++ space ++ "'" memblockFromMem :: VName -> CSExp memblockFromMem mem =@@ -392,7 +391,7 @@ where dims' = map CS.compileDim dims packArrayOutput _ sid _ _ _ =- fail $ "Cannot return array from " ++ sid ++ " space."+ error $ "Cannot return array from " ++ sid ++ " space." unpackArrayInput :: CS.EntryInput Imp.OpenCL () unpackArrayInput mem "device" t _ dims e = do@@ -415,7 +414,7 @@ where dims' = map CS.compileDim dims unpackArrayInput _ sid _ _ _ _ =- fail $ "Cannot accept array from " ++ sid ++ " space."+ error $ "Cannot accept array from " ++ sid ++ " space." futharkSyncContext :: CSStmt futharkSyncContext = Exp $ CS.simpleCall "FutharkContextSync" []
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -200,23 +200,23 @@ , opsFatMemory = True } where defWriteScalar _ _ _ _ _ =- fail "Cannot write to non-default memory space because I am dumb"+ error "Cannot write to non-default memory space because I am dumb" defReadScalar _ _ _ _ =- fail "Cannot read from non-default memory space"+ error "Cannot read from non-default memory space" defAllocate _ _ _ =- fail "Cannot allocate in non-default memory space"+ error "Cannot allocate in non-default memory space" defDeallocate _ _ =- fail "Cannot deallocate in non-default memory space"+ error "Cannot deallocate in non-default memory space" defCopy destmem destoffset DefaultSpace srcmem srcoffset DefaultSpace size = copyMemoryDefaultSpace destmem destoffset srcmem srcoffset size defCopy _ _ _ _ _ _ _ =- fail "Cannot copy to or from non-default memory space"+ error "Cannot copy to or from non-default memory space" defStaticArray _ _ _ _ =- fail "Cannot create static array in non-default memory space"+ error "Cannot create static array in non-default memory space" defMemoryType _ =- fail "Has no type for non-default memory space"+ error "Has no type for non-default memory space" defCompiler _ =- fail "The default compiler cannot compile extended operations"+ error "The default compiler cannot compile extended operations" data CompilerEnv op s = CompilerEnv { envOperations :: Operations op s@@ -792,10 +792,12 @@ } $ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr) {+ (void)ctx; return $exp:arr_raw_mem; } typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr) {+ (void)ctx; return arr->shape; } |]@@ -1708,11 +1710,16 @@ { $items:items } |] -compileCode (DebugPrint s (Just (_, e))) = do+compileCode (DebugPrint s (Just e)) = do e' <- compileExp e stm [C.cstm|if (ctx->debugging) {- fprintf(stderr, "%s: %d\n", $exp:s, (int)$exp:e');+ fprintf(stderr, $string:fmtstr, $exp:s, ($ty:ety)$exp:e', '\n'); }|]+ where (fmt, ety) = case primExpType e of+ IntType _ -> ("llu", [C.cty|long long int|])+ FloatType _ -> ("f", [C.cty|double|])+ _ -> ("d", [C.cty|int|])+ fmtstr = "%s: %" ++ fmt ++ "%c" compileCode (DebugPrint s Nothing) = stm [C.cstm|if (ctx->debugging) {
src/Futhark/CodeGen/Backends/GenericCSharp.hs view
@@ -84,7 +84,6 @@ import Futhark.CodeGen.Backends.GenericCSharp.AST import Futhark.CodeGen.Backends.GenericCSharp.Options import Futhark.CodeGen.Backends.GenericCSharp.Definitions-import Futhark.Util.Pretty(pretty) import Futhark.Util (zEncodeString) import Futhark.Representation.AST.Attributes (builtInFunctions) import Text.Printf (printf)@@ -156,21 +155,21 @@ , opsSyncRun = defSyncRun } where defWriteScalar _ _ _ _ _ =- fail "Cannot write to non-default memory space because I am dumb"+ error "Cannot write to non-default memory space because I am dumb" defReadScalar _ _ _ _ =- fail "Cannot read from non-default memory space"+ error "Cannot read from non-default memory space" defAllocate _ _ _ =- fail "Cannot allocate in non-default memory space"+ error "Cannot allocate in non-default memory space" defCopy _ _ _ _ _ _ _ _ =- fail "Cannot copy to or from non-default memory space"+ error "Cannot copy to or from non-default memory space" defStaticArray _ _ _ _ =- fail "Cannot create static array in non-default memory space"+ error "Cannot create static array in non-default memory space" defCompiler _ =- fail "The default compiler cannot compile extended operations"+ error "The default compiler cannot compile extended operations" defEntryOutput _ _ _ _ =- fail "Cannot return array not in default memory space"+ error "Cannot return array not in default memory space" defEntryInput _ _ _ _ =- fail "Cannot accept array not in default memory space"+ error "Cannot accept array not in default memory space" defSyncRun = Pass @@ -457,8 +456,8 @@ (filter (Imp.functionEntry . snd) funs) debug_ending <- gets compDebugItems- return [Namespace name ((ClassDef $- PublicClass name $+ return [Namespace name (ClassDef+ (PublicClass name $ member_decls' ++ constructor' : defines' ++ opencl_boilerplate ++@@ -1179,6 +1178,7 @@ FSub{} -> simple "-" FMul{} -> simple "*" FDiv{} -> simple "/"+ FMod{} -> simple "%" LogAnd{} -> simple "&&" LogOr{} -> simple "||" _ -> return $ simpleCall (pretty op) [x', y']@@ -1276,7 +1276,7 @@ let onPart (i, Imp.ErrorString s) = return (printFormatArg i, String s) onPart (i, Imp.ErrorInt32 x) = (printFormatArg i,) <$> compileExp x (formatstrs, formatargs) <- unzip <$> mapM onPart (zip ([1..] :: [Integer]) parts)- stm $ Assert e' $ (String $ "Error at {0}:\n" <> concat formatstrs) : (String stacktrace : formatargs)+ stm $ Assert e' $ String ("Error at {0}:\n" <> concat formatstrs) : (String stacktrace : formatargs) where stacktrace = intercalate " -> " (reverse $ map locStr $ loc:locs) printFormatArg = printf "{%d}" @@ -1374,7 +1374,7 @@ , (String . compileName) mem] unRefMem _ DefaultSpace = stm Pass unRefMem _ (Space "local") = stm Pass-unRefMem _ (Space _) = fail "The default compiler cannot compile unRefMem for other spaces"+unRefMem _ (Space _) = error "The default compiler cannot compile unRefMem for other spaces" -- | Public names must have a consistent prefix.
src/Futhark/CodeGen/Backends/GenericPython.hs view
@@ -61,7 +61,6 @@ import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.GenericPython.Definitions-import Futhark.Util.Pretty(pretty) import Futhark.Util (zEncodeString) import Futhark.Representation.AST.Attributes (builtInFunctions, isBuiltInFunction) @@ -131,21 +130,21 @@ , opsEntryInput = defEntryInput } where defWriteScalar _ _ _ _ _ =- fail "Cannot write to non-default memory space because I am dumb"+ error "Cannot write to non-default memory space because I am dumb" defReadScalar _ _ _ _ =- fail "Cannot read from non-default memory space"+ error "Cannot read from non-default memory space" defAllocate _ _ _ =- fail "Cannot allocate in non-default memory space"+ error "Cannot allocate in non-default memory space" defCopy _ _ _ _ _ _ _ _ =- fail "Cannot copy to or from non-default memory space"+ error "Cannot copy to or from non-default memory space" defStaticArray _ _ _ _ =- fail "Cannot create static array in non-default memory space"+ error "Cannot create static array in non-default memory space" defCompiler _ =- fail "The default compiler cannot compile extended operations"+ error "The default compiler cannot compile extended operations" defEntryOutput _ _ _ _ =- fail "Cannot return array not in default memory space"+ error "Cannot return array not in default memory space" defEntryInput _ _ _ _ =- fail "Cannot accept array not in default memory space"+ error "Cannot accept array not in default memory space" data CompilerEnv op s = CompilerEnv { envOperations :: Operations op s@@ -804,6 +803,7 @@ FSub{} -> simple "-" FMul{} -> simple "*" FDiv{} -> simple "/"+ FMod{} -> simple "%" Xor{} -> simple "^" And{} -> simple "&" Or{} -> simple "|"
src/Futhark/CodeGen/Backends/PyOpenCL.hs view
@@ -14,7 +14,6 @@ import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.GenericPython.Definitions-import Futhark.Util.Pretty(pretty) import Futhark.MonadFreshNames @@ -183,7 +182,7 @@ ArgKeyword "is_blocking" $ Var "synchronous"] writeOpenCLScalar _ _ _ space _ =- fail $ "Cannot write to '" ++ space ++ "' memory space."+ error $ "Cannot write to '" ++ space ++ "' memory space." readOpenCLScalar :: Py.ReadScalar Imp.OpenCL () readOpenCLScalar mem i bt "device" = do@@ -201,7 +200,7 @@ return $ Index val' $ IdxExp $ Integer 0 readOpenCLScalar _ _ _ space =- fail $ "Cannot read from '" ++ space ++ "' memory space."+ error $ "Cannot read from '" ++ space ++ "' memory space." allocateOpenCLBuffer :: Py.Allocate Imp.OpenCL () allocateOpenCLBuffer mem size "device" =@@ -209,7 +208,7 @@ Py.simpleCall "opencl_alloc" [Var "self", size, String $ pretty mem] allocateOpenCLBuffer _ _ space =- fail $ "Cannot allocate in '" ++ space ++ "' space"+ error $ "Cannot allocate in '" ++ space ++ "' space" copyOpenCLMemory :: Py.Copy Imp.OpenCL () copyOpenCLMemory destmem destidx Imp.DefaultSpace srcmem srcidx (Imp.Space "device") nbytes bt = do@@ -290,7 +289,7 @@ Py.stm $ Assign (Var name') (Field (Var "self") name') where name' = Py.compileName name staticOpenCLArray _ space _ _ =- fail $ "PyOpenCL backend cannot create static array in memory space '" ++ space ++ "'"+ error $ "PyOpenCL backend cannot create static array in memory space '" ++ space ++ "'" packArrayOutput :: Py.EntryOutput Imp.OpenCL () packArrayOutput mem "device" bt ept dims =@@ -300,7 +299,7 @@ Arg $ Var $ Py.compilePrimTypeExt bt ept, ArgKeyword "data" $ Var $ Py.compileName mem] packArrayOutput _ sid _ _ _ =- fail $ "Cannot return array from " ++ sid ++ " space."+ error $ "Cannot return array from " ++ sid ++ " space." unpackArrayInput :: Py.EntryInput Imp.OpenCL () unpackArrayInput mem "device" t s dims e = do@@ -329,7 +328,7 @@ numpyArrayCase where mem_dest = Var $ Py.compileName mem unpackArrayInput _ sid _ _ _ _ =- fail $ "Cannot accept array from " ++ sid ++ " space."+ error $ "Cannot accept array from " ++ sid ++ " space." ifNotZeroSize :: PyExp -> PyStmt -> PyStmt ifNotZeroSize e s =
src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs view
@@ -14,7 +14,7 @@ import Futhark.CodeGen.ImpCode.OpenCL (PrimType(..), SizeClass(..)) import Futhark.CodeGen.OpenCL.Heuristics import Futhark.CodeGen.Backends.GenericPython.AST-import Futhark.Util.Pretty (pretty, prettyText)+import Futhark.Util.Pretty (prettyText) -- | @rts/python/opencl.py@ embedded as a string. openClPrelude :: String
src/Futhark/CodeGen/Backends/SimpleRepresentation.hs view
@@ -16,7 +16,6 @@ , cFloat32Ops, cFloat32Funs , cFloat64Ops, cFloat64Funs , cFloatConvOps- ) where @@ -24,7 +23,7 @@ import qualified Language.C.Quote.C as C import Futhark.CodeGen.ImpCode-import Futhark.Util.Pretty (pretty, prettyOneLine)+import Futhark.Util.Pretty (prettyOneLine) import Futhark.Util (zEncodeString) -- | The C type corresponding to a signed integer type.@@ -238,8 +237,8 @@ mkFAdd = simpleFloatOp "fadd" [C.cexp|x + y|] mkFSub = simpleFloatOp "fsub" [C.cexp|x - y|] mkFMul = simpleFloatOp "fmul" [C.cexp|x * y|]- mkFMin = simpleFloatOp "fmin" [C.cexp|x < y ? x : y|]- mkFMax = simpleFloatOp "fmax" [C.cexp|x < y ? y : x|]+ mkFMin = simpleFloatOp "fmin" [C.cexp|fmin(x, y)|]+ mkFMax = simpleFloatOp "fmax" [C.cexp|fmax(x, y)|] mkCmpLt = floatCmpOp "cmplt" [C.cexp|x < y|] mkCmpLe = floatCmpOp "cmple" [C.cexp|x <= y|] @@ -325,10 +324,6 @@ return lgamma(x); } - static inline float $id:(funName' "round32")(float x) {- return rint(x);- }- static inline char $id:(funName' "isnan32")(float x) { return isnan(x); }@@ -354,6 +349,40 @@ p.f = x; return p.t; }++$esc:("#ifdef __OPENCL_VERSION__")+ static inline float fmod32(float x, float y) {+ return fmod(x, y);+ }+ static inline float $id:(funName' "round32")(float x) {+ return rint(x);+ }+ static inline float $id:(funName' "floor32")(float x) {+ return floor(x);+ }+ static inline float $id:(funName' "ceil32")(float x) {+ return ceil(x);+ }+ static inline float $id:(funName' "lerp32")(float v0, float v1, float t) {+ return mix(v0, v1, t);+ }+$esc:("#else")+ static inline float fmod32(float x, float y) {+ return fmodf(x, y);+ }+ static inline float $id:(funName' "round32")(float x) {+ return rintf(x);+ }+ static inline float $id:(funName' "floor32")(float x) {+ return floorf(x);+ }+ static inline float $id:(funName' "ceil32")(float x) {+ return ceilf(x);+ }+ static inline float $id:(funName' "lerp32")(float v0, float v1, float t) {+ return v0 + (v1-v0)*t;+ }+$esc:("#endif") |] cFloat64Funs :: [C.Definition]@@ -418,6 +447,14 @@ return rint(x); } + static inline double $id:(funName' "ceil64")(double x) {+ return ceil(x);+ }++ static inline double $id:(funName' "floor64")(double x) {+ return floor(x);+ }+ static inline char $id:(funName' "isnan64")(double x) { return isnan(x); }@@ -443,4 +480,18 @@ p.f = x; return p.t; }++ static inline float fmod64(float x, float y) {+ return fmod(x, y);+ }++$esc:("#ifdef __OPENCL_VERSION__")+ static inline double $id:(funName' "lerp64")(double v0, double v1, double t) {+ return mix(v0, v1, t);+ }+$esc:("#else")+ static inline double $id:(funName' "lerp64")(double v0, double v1, double t) {+ return v0 + (v1-v0)*t;+ }+$esc:("#endif") |]
src/Futhark/CodeGen/ImpCode.hs view
@@ -57,7 +57,6 @@ ) where -import Data.Monoid ((<>)) import Data.List import Data.Loc import Data.Traversable@@ -183,13 +182,13 @@ -- ^ Has the same semantics as the contained code, but -- the comment should show up in generated code for ease -- of inspection.- | DebugPrint String (Maybe (PrimType, Exp))- -- ^ Print the given value (of the given type) to the- -- screen, somehow annotated with the given string as a- -- description. If no type/value pair, just print the- -- string. This has no semantic meaning, but is used- -- entirely for debugging. Code generators are free to- -- ignore this statement.+ | DebugPrint String (Maybe Exp)+ -- ^ Print the given value to the screen, somehow+ -- annotated with the given string as a description. If+ -- no type/value pair, just print the string. This has+ -- no semantic meaning, but is used entirely for+ -- debugging. Code generators are free to ignore this+ -- statement. | Op a deriving (Show) @@ -359,8 +358,8 @@ ppr fname <> parens (commasep $ map ppr args) ppr (Comment s code) = text "--" <+> text s </> ppr code- ppr (DebugPrint desc (Just (pt, e))) =- text "debug" <+> parens (commasep [text (show desc), ppr pt, ppr e])+ ppr (DebugPrint desc (Just e)) =+ text "debug" <+> parens (commasep [text (show desc), ppr e]) ppr (DebugPrint desc Nothing) = text "debug" <+> parens (text (show desc)) @@ -497,7 +496,7 @@ freeIn' (Comment _ code) = freeIn' code freeIn' (DebugPrint _ v) =- maybe mempty (freeIn' . snd) v+ maybe mempty freeIn' v instance FreeIn ExpLeaf where freeIn' (Index v e _ _ _) = freeIn' v <> freeIn' e
src/Futhark/CodeGen/ImpCode/Kernels.hs view
@@ -13,7 +13,6 @@ , KernelOp (..) , AtomicOp (..) , Kernel (..)- , LocalMemoryUse , KernelUse (..) , module Futhark.CodeGen.ImpCode , module Futhark.Representation.Kernels.Sizes@@ -68,9 +67,6 @@ } deriving (Show) --- ^ In-kernel name and per-workgroup size in bytes.-type LocalMemoryUse = (VName, Either (Count Bytes Exp) KernelConstExp)- data KernelUse = ScalarUse VName PrimType | MemoryUse VName | ConstUse VName KernelConstExp@@ -154,7 +150,7 @@ | MemFenceLocal | MemFenceGlobal | PrivateAlloc VName (Count Bytes Imp.Exp)- | LocalAlloc VName (Either (Count Bytes Imp.Exp) KernelConstExp)+ | LocalAlloc VName (Count Bytes Imp.Exp) deriving (Show) -- Atomic operations return the value stored before the update.@@ -213,9 +209,7 @@ ppr (PrivateAlloc name size) = ppr name <+> equals <+> text "private_alloc" <> parens (ppr size) ppr (LocalAlloc name size) =- ppr name <+> equals <+> text "local_alloc" <>- parens (either ppr constCase size)- where constCase e = text "(constant)" <+> ppr e+ ppr name <+> equals <+> text "local_alloc" <> parens (ppr size) ppr (Atomic _ (AtomicAdd old arr ind x)) = ppr old <+> text "<-" <+> text "atomic_add" <> parens (commasep [ppr arr <> brackets (ppr ind), ppr x])
src/Futhark/CodeGen/ImpGen.hs view
@@ -71,7 +71,7 @@ , dScope , dScopes , dArray- , dPrim, dPrim_, dPrimV_, dPrimV+ , dPrim, dPrim_, dPrimV_, dPrimV, dPrimVE , sFor, sWhile , sComment@@ -99,8 +99,7 @@ import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.CodeGen.ImpCode- (Count (..),- Bytes, Elements,+ (Bytes, Elements, bytes, elements, withElemType) import Futhark.Representation.ExplicitMemory import Futhark.Representation.SOACS (SOACS)@@ -596,7 +595,7 @@ return () dLParams $ map fst loopvars- sFor i it (toExp' (IntType it) bound) $+ sFor' i it (toExp' (IntType it) bound) $ mapM_ setLoopParam loopvars >> doBody WhileLoop cond -> sWhile (Imp.var cond Bool) doBody@@ -663,17 +662,14 @@ defCompileBasicOp _ Scratch{} = return () -defCompileBasicOp (Pattern [] [pe]) (Iota n e s et) = do- i <- newVName "i"- x <- newVName "x"+defCompileBasicOp (Pattern [] [pe]) (Iota n e s it) = do n' <- toExp n e' <- toExp e s' <- toExp s- let i' = ConvOpExp (SExt Int32 et) $ Imp.var i $ IntType Int32- dPrim_ x $ IntType et- sFor i Int32 n' $ do- x <-- e' + i' * s'- copyDWIM (patElemName pe) [Imp.vi32 i] (Var x) []+ sFor "i" n' $ \i -> do+ let i' = ConvOpExp (SExt Int32 it) i+ x <- dPrimV "x" $ e' + i' * s'+ copyDWIM (patElemName pe) [i] (Var x) [] defCompileBasicOp (Pattern _ [pe]) (Copy src) = copyDWIM (patElemName pe) [] (Var src) []@@ -789,6 +785,11 @@ name' <-- e return name' +dPrimVE :: String -> Imp.Exp -> ImpM lore op Imp.Exp+dPrimVE name e = do name' <- dPrim name $ primExpType e+ name' <-- e+ return $ Imp.var name' $ primExpType e+ memBoundToVarEntry :: Maybe (Exp lore) -> MemBound NoUniqueness -> ImpM lore op (VarEntry lore) memBoundToVarEntry e (MemPrim bt) =@@ -1185,12 +1186,22 @@ --- Building blocks for constructing code. -sFor :: VName -> IntType -> Imp.Exp -> ImpM lore op () -> ImpM lore op ()-sFor i it bound body = do+sFor' :: VName -> IntType -> Imp.Exp -> ImpM lore op () -> ImpM lore op ()+sFor' i it bound body = do addLoopVar i it body' <- collect body emit $ Imp.For i it bound body' +sFor :: String -> Imp.Exp -> (Imp.Exp -> ImpM lore op ()) -> ImpM lore op ()+sFor i bound body = do+ i' <- newVName i+ it <- case primExpType bound of+ IntType it -> return it+ t -> compilerBugS $ "sFor: bound " ++ pretty bound ++ " is of type " ++ pretty t+ addLoopVar i' it+ body' <- collect $ body $ Imp.var i' $ IntType it+ emit $ Imp.For i' it bound body'+ sWhile :: Imp.Exp -> ImpM lore op () -> ImpM lore op () sWhile cond body = do body' <- collect body@@ -1285,9 +1296,8 @@ sLoopNest = sLoopNest' [] . shapeDims where sLoopNest' is [] f = f $ reverse is sLoopNest' is (d:ds) f = do- i <- newVName "nest_i" d' <- toExp d- sFor i Int32 d' $ sLoopNest' (Imp.var i int32:is) ds f+ sFor "nest_i" d' $ \i -> sLoopNest' (i:is) ds f -- | ASsignment. (<--) :: VName -> Imp.Exp -> ImpM lore op ()
src/Futhark/CodeGen/ImpGen/Kernels.hs view
@@ -24,11 +24,11 @@ import Futhark.CodeGen.ImpGen.Kernels.SegMap import Futhark.CodeGen.ImpGen.Kernels.SegRed import Futhark.CodeGen.ImpGen.Kernels.SegScan-import Futhark.CodeGen.ImpGen.Kernels.SegGenRed+import Futhark.CodeGen.ImpGen.Kernels.SegHist import Futhark.CodeGen.ImpGen.Kernels.Transpose import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun import Futhark.CodeGen.SetDefaultSpace-import Futhark.Util.IntegralExp (quot, IntegralExp)+import Futhark.Util.IntegralExp (quot, quotRoundingUp, IntegralExp) callKernelOperations :: Operations ExplicitMemory Imp.HostOp callKernelOperations =@@ -46,21 +46,49 @@ opCompiler :: Pattern ExplicitMemory -> Op ExplicitMemory -> CallKernelGen ()+ opCompiler dest (Alloc e space) = compileAlloc dest e space-opCompiler (Pattern _ [pe]) (Inner (GetSize key size_class)) = do++opCompiler (Pattern _ [pe]) (Inner (SizeOp (GetSize key size_class))) = do fname <- asks envFunction sOp $ Imp.GetSize (patElemName pe) (keyWithEntryPoint fname key) $ sizeClassWithEntryPoint fname size_class-opCompiler (Pattern _ [pe]) (Inner (CmpSizeLe key size_class x)) = do++opCompiler (Pattern _ [pe]) (Inner (SizeOp (CmpSizeLe key size_class x))) = do fname <- asks envFunction let size_class' = sizeClassWithEntryPoint fname size_class sOp . Imp.CmpSizeLe (patElemName pe) (keyWithEntryPoint fname key) size_class' =<< toExp x-opCompiler (Pattern _ [pe]) (Inner (GetSizeMax size_class)) =++opCompiler (Pattern _ [pe]) (Inner (SizeOp (GetSizeMax size_class))) = sOp $ Imp.GetSizeMax (patElemName pe) size_class++opCompiler (Pattern _ [pe]) (Inner (SizeOp (CalcNumGroups w64 max_num_groups_key group_size))) = do+ fname <- asks envFunction+ max_num_groups <- dPrim "max_num_groups" int32+ sOp $ Imp.GetSize max_num_groups (keyWithEntryPoint fname max_num_groups_key) $+ sizeClassWithEntryPoint fname SizeNumGroups++ -- If 'w' is small, we launch fewer groups than we normally would.+ -- We don't want any idle groups.+ --+ -- The calculations are done with 64-bit integers to avoid overflow+ -- issues.+ let num_groups_maybe_zero = BinOpExp (SMin Int64)+ (toExp' int64 w64 `quotRoundingUp`+ i64 (toExp' int32 group_size)) $+ i64 (Imp.vi32 max_num_groups)+ -- We also don't want zero groups.+ let num_groups = BinOpExp (SMax Int64) 1 num_groups_maybe_zero+ patElemName pe <-- i32 num_groups++ where i64 = ConvOpExp (SExt Int32 Int64)+ i32 = ConvOpExp (SExt Int64 Int32)+ opCompiler dest (Inner (SegOp op)) = segOpCompiler dest op+ opCompiler pat e = compilerBugS $ "opCompiler: Invalid pattern\n " ++ pretty pat ++ "\nfor expression\n " ++ pretty e@@ -78,8 +106,8 @@ compileSegRed pat lvl space reds kbody segOpCompiler pat (SegScan lvl@SegThread{} space scan_op nes _ kbody) = compileSegScan pat lvl space scan_op nes kbody-segOpCompiler pat (SegGenRed (SegThread num_groups group_size _) space ops _ kbody) =- compileSegGenRed pat num_groups group_size space ops kbody+segOpCompiler pat (SegHist (SegThread num_groups group_size _) space ops _ kbody) =+ compileSegHist pat num_groups group_size space ops kbody segOpCompiler pat segop = compilerBugS $ "segOpCompiler: unexpected " ++ pretty (segLevel segop) ++ " for rhs of pattern " ++ pretty pat
src/Futhark/CodeGen/ImpGen/Kernels/Base.hs view
@@ -19,13 +19,17 @@ , compileThreadResult , compileGroupResult , virtualiseGroups+ , groupLoop+ , kernelLoop+ , groupCoverSpace , getSize , atomicUpdate , atomicUpdateLocking , Locking(..)- , AtomicUpdate+ , AtomicUpdate(..)+ , DoAtomicUpdate ) where @@ -42,11 +46,12 @@ import Futhark.MonadFreshNames import Futhark.Transform.Rename import Futhark.Representation.ExplicitMemory+import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpCode.Kernels (elements) import Futhark.CodeGen.ImpGen import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem)-import Futhark.Util (chunks, maybeNth)+import Futhark.Util (chunks, maybeNth, mapAccumLM, takeLast) type CallKernelGen = ImpM ExplicitMemory Imp.HostOp type InKernelGen = ImpM ExplicitMemory Imp.KernelOp@@ -79,10 +84,8 @@ allocLocal, allocPrivate :: AllocCompiler ExplicitMemory Imp.KernelOp-allocLocal mem size = do- vtable <- getVTable- size' <- localMemSize vtable size- sOp $ Imp.LocalAlloc mem size'+allocLocal mem size =+ sOp $ Imp.LocalAlloc mem size allocPrivate mem size = sOp $ Imp.PrivateAlloc mem size @@ -125,20 +128,27 @@ compileThreadExp dest e = defCompileExp dest e ++-- | Assign iterations of a for-loop to all threads in the kernel. The+-- passed-in function is invoked with the (symbolic) iteration. For+-- multidimensional loops, use 'groupCoverSpace'.+kernelLoop :: Imp.Exp -> Imp.Exp -> Imp.Exp+ -> (Imp.Exp -> InKernelGen ()) -> InKernelGen ()+kernelLoop tid num_threads n f = do+ -- Compute how many elements this thread is responsible for.+ -- Formula: (n - tid) / num_threads (rounded up).+ let elems_for_this = (n - tid) `quotRoundingUp` num_threads++ sFor "i" elems_for_this $ \i -> f $+ i * num_threads + tid+ -- | Assign iterations of a for-loop to threads in the workgroup. The -- passed-in function is invoked with the (symbolic) iteration. For -- multidimensional loops, use 'groupCoverSpace'. groupLoop :: KernelConstants -> Imp.Exp -> (Imp.Exp -> InKernelGen ()) -> InKernelGen ()-groupLoop constants n f = do- i <- newVName "i"-- -- Compute how many elements this thread is responsible for.- -- Formula: (n - ltid) / group_size (rounded up).- let ltid = kernelLocalThreadId constants- elems_for_this = (n - ltid) `quotRoundingUp` kernelGroupSize constants-- sFor i Int32 elems_for_this $ f $ Imp.vi32 i+groupLoop constants =+ kernelLoop (kernelLocalThreadId constants) (kernelGroupSize constants) -- | Iterate collectively though a multidimensional space, such that -- all threads in the group participate. The passed-in function is@@ -146,11 +156,7 @@ groupCoverSpace :: KernelConstants -> [Imp.Exp] -> ([Imp.Exp] -> InKernelGen ()) -> InKernelGen () groupCoverSpace constants ds f =- groupLoop constants (product ds) $ \i -> do- let is = unflattenIndex ds $- i * kernelGroupSize constants +- kernelLocalThreadId constants- f is+ groupLoop constants (product ds) $ f . unflattenIndex ds groupCopy :: KernelConstants -> VName -> [Imp.Exp] -> SubExp -> [Imp.Exp] -> InKernelGen () groupCopy constants to to_is from from_is = do@@ -174,6 +180,7 @@ ds' <- mapM toExp $ shapeDims ds groupCoverSpace constants ds' $ \is -> copyDWIM (patElemName dest) is se (drop (shapeRank ds) is)+ sOp Imp.LocalBarrier compileGroupExp constants (Pattern _ [dest]) (BasicOp (Iota n e s _)) = do n' <- toExp n e' <- toExp e@@ -181,6 +188,7 @@ groupLoop constants n' $ \i' -> do x <- dPrimV "x" $ e' + i' * s' copyDWIM (patElemName dest) [i'] (Var x) []+ sOp Imp.LocalBarrier compileGroupExp _ dest e = defCompileExp dest e@@ -201,12 +209,49 @@ dPrimV_ (segFlat space) $ kernelLocalThreadId constants +-- Construct the necessary lock arrays for an intra-group histogram.+prepareIntraGroupSegHist :: KernelConstants+ -> Count GroupSize SubExp+ -> [HistOp ExplicitMemory]+ -> InKernelGen [[Imp.Exp] -> InKernelGen ()]+prepareIntraGroupSegHist constants group_size =+ fmap snd . mapAccumLM onOp Nothing+ where+ onOp l op = do++ let local_subhistos = histDest op++ case (l, atomicUpdateLocking $ histOp op) of+ (_, AtomicPrim f) -> return (l, f (Space "local") local_subhistos)+ (_, AtomicCAS f) -> return (l, f (Space "local") local_subhistos)+ (Just l', AtomicLocking f) -> return (l, f l' (Space "local") local_subhistos)+ (Nothing, AtomicLocking f) -> do+ locks <- newVName "locks"+ num_locks <- toExp $ unCount group_size++ let dims = map (toExp' int32) $+ shapeDims (histShape op) +++ [histWidth op]+ l' = Locking locks 0 1 0 (pure . (`rem` num_locks) . flattenIndex dims)+ locks_t = Array int32 (Shape [unCount group_size]) NoUniqueness++ locks_mem <- sAlloc "locks_mem" (typeSize locks_t) $ Space "local"+ dArray locks int32 (arrayShape locks_t) $+ ArrayIn locks_mem $ IxFun.iota $+ map (primExpFromSubExp int32) $ arrayDims locks_t++ sComment "All locks start out unlocked" $+ groupCoverSpace constants [kernelGroupSize constants] $ \is ->+ copyDWIM locks is (intConst Int32 0) []++ return (Just l', f l' (Space "local") local_subhistos)+ compileGroupOp :: KernelConstants -> OpCompiler ExplicitMemory Imp.KernelOp compileGroupOp constants pat (Alloc size space) = kernelAlloc constants pat size space -compileGroupOp _ pat (Inner (SplitSpace o w i elems_per_thread)) =+compileGroupOp _ pat (Inner (SizeOp (SplitSpace o w i elems_per_thread))) = splitSpace pat o w i elems_per_thread compileGroupOp constants pat (Inner (SegOp (SegMap lvl space _ body))) = do@@ -263,6 +308,8 @@ sOp Imp.LocalBarrier case dims' of+ -- Nonsegmented case (or rather, a single segment) - this we can+ -- handle directly with a group-level reduction. [dim'] -> do forM_ (zip ops tmps_for_ops) $ \(op, tmps) -> groupReduce constants dim' (segRedLambda op) tmps@@ -273,6 +320,9 @@ copyDWIM (patElemName pe) [] (Var arr) [0] _ -> do+ -- Segmented intra-group reductions are turned into (regular)+ -- segmented scans. It is possible that this can be done+ -- better, but at least this approach is simple. let segment_size = last dims' crossesSegment from to = (to-from) .>. (to `rem` segment_size) @@ -285,14 +335,55 @@ forM_ (zip red_pes tmp_arrs) $ \(pe, arr) -> copyDWIM (patElemName pe) segment_is (Var arr) (segment_is ++ [last dims'-1]) +compileGroupOp constants pat (Inner (SegOp (SegHist lvl space ops _ kbody))) = do+ compileGroupSpace constants lvl space+ let ltids = map fst $ unSegSpace space + -- We don't need the red_pes, because it is guaranteed by our type+ -- rules that they occupy the same memory as the destinations for+ -- the ops.+ let num_red_res = length ops + sum (map (length . histNeutral) ops)+ (_red_pes, map_pes) =+ splitAt num_red_res $ patternElements pat++ ops' <- prepareIntraGroupSegHist constants (segGroupSize lvl) ops++ -- Ensure that all locks have been initialised.+ sOp Imp.LocalBarrier++ sWhen (isActive $ unSegSpace space) $+ compileStms mempty (kernelBodyStms kbody) $ do+ let (red_res, map_res) = splitAt num_red_res $ kernelBodyResult kbody+ (red_is, red_vs) = splitAt (length ops) $ map kernelResultSubExp red_res+ zipWithM_ (compileThreadResult space constants) map_pes map_res++ let vs_per_op = chunks (map (length . histDest) ops) red_vs++ forM_ (zip4 red_is vs_per_op ops' ops) $+ \(bin, op_vs, do_op, HistOp dest_w _ _ _ shape lam) -> do+ let bin' = toExp' int32 bin+ dest_w' = toExp' int32 dest_w+ bin_in_bounds = 0 .<=. bin' .&&. bin' .<. dest_w'+ bin_is = map (`Imp.var` int32) (init ltids) ++ [bin']+ vs_params = takeLast (length op_vs) $ lambdaParams lam++ sComment "perform atomic updates" $+ sWhen bin_in_bounds $ do+ dLParams $ lambdaParams lam+ sLoopNest shape $ \is -> do+ forM_ (zip vs_params op_vs) $ \(p, v) ->+ copyDWIM (paramName p) [] v is+ do_op (bin_is ++ is)++ sOp Imp.LocalBarrier+ compileGroupOp _ pat _ = compilerBugS $ "compileGroupOp: cannot compile rhs of binding " ++ pretty pat compileThreadOp :: KernelConstants -> OpCompiler ExplicitMemory Imp.KernelOp compileThreadOp constants pat (Alloc size space) = kernelAlloc constants pat size space-compileThreadOp _ pat (Inner (SplitSpace o w i elems_per_thread)) =+compileThreadOp _ pat (Inner (SizeOp (SplitSpace o w i elems_per_thread))) = splitSpace pat o w i elems_per_thread compileThreadOp _ pat _ = compilerBugS $ "compileThreadOp: cannot compile rhs of binding " ++ pretty pat@@ -307,7 +398,7 @@ -- ^ What to write when we lock it. , lockingToUnlock :: Imp.Exp -- ^ What to write when we unlock it.- , lockingMapping :: [Imp.Exp] -> Imp.Exp+ , lockingMapping :: [Imp.Exp] -> [Imp.Exp] -- ^ A transformation from the logical lock index to the -- physical position in the array. This can also be used -- to make the lock array smaller.@@ -315,26 +406,37 @@ -- | A function for generating code for an atomic update. Assumes -- that the bucket is in-bounds.-type AtomicUpdate lore =+type DoAtomicUpdate lore = Space -> [VName] -> [Imp.Exp] -> ImpM lore Imp.KernelOp () +-- | The mechanism that will be used for performing the atomic update.+-- Approximates how efficient it will be. Ordered from most to least+-- efficient.+data AtomicUpdate lore+ = AtomicPrim (DoAtomicUpdate lore)+ -- ^ Supported directly by primitive.+ | AtomicCAS (DoAtomicUpdate lore)+ -- ^ Can be done by efficient swaps.+ | AtomicLocking (Locking -> DoAtomicUpdate lore)+ -- ^ Requires explicit locking.+ atomicUpdate :: ExplicitMemorish lore => Space -> [VName] -> [Imp.Exp] -> Lambda lore -> Locking -> ImpM lore Imp.KernelOp () atomicUpdate space arrs bucket lam locking = case atomicUpdateLocking lam of- Left f -> f space arrs bucket- Right f -> f locking space arrs bucket+ AtomicPrim f -> f space arrs bucket+ AtomicCAS f -> f space arrs bucket+ AtomicLocking f -> f locking space arrs bucket -- | 'atomicUpdate', but where it is explicitly visible whether a -- locking strategy is necessary. atomicUpdateLocking :: ExplicitMemorish lore =>- Lambda lore- -> Either (AtomicUpdate lore) (Locking -> AtomicUpdate lore)+ Lambda lore -> AtomicUpdate lore atomicUpdateLocking lam | Just ops_and_ts <- splitOp lam,- all (\(_, t, _, _) -> primBitSize t == 32) ops_and_ts = Left $ \space arrs bucket ->+ all (\(_, t, _, _) -> primBitSize t == 32) ops_and_ts = AtomicPrim $ \space arrs bucket -> -- If the operator is a vectorised binary operator on 32-bit values, -- we can use a particularly efficient implementation. If the -- operator has an atomic implementation we use that, otherwise it@@ -362,18 +464,18 @@ atomicUpdateLocking op | [Prim t] <- lambdaReturnType op, [xp, _] <- lambdaParams op,- primBitSize t == 32 = Left $ \space [arr] bucket -> do+ primBitSize t == 32 = AtomicCAS $ \space [arr] bucket -> do old <- dPrim "old" t atomicUpdateCAS space t arr old bucket (paramName xp) $ compileBody' [xp] $ lambdaBody op -atomicUpdateLocking op = Right $ \locking space arrs bucket -> do+atomicUpdateLocking op = AtomicLocking $ \locking space arrs bucket -> do old <- dPrim "old" int32 continue <- dPrimV "continue" true -- Correctly index into locks. (locks', _locks_space, locks_offset) <-- fullyIndexArray (lockingArray locking) [lockingMapping locking bucket]+ fullyIndexArray (lockingArray locking) $ lockingMapping locking bucket -- Critical section let try_acquire_lock =@@ -407,7 +509,7 @@ let op_body = sComment "execute operation" $ compileBody' acc_params $ lambdaBody op - do_gen_reduce =+ do_hist = everythingVolatile $ sComment "update global result" $ zipWithM_ (writeArray bucket) arrs $ map (Var . paramName) acc_params@@ -423,7 +525,7 @@ dLParams acc_params bind_acc_params op_body- do_gen_reduce+ do_hist fence release_lock break_loop@@ -508,12 +610,6 @@ Nothing | bt == Cert -> return Nothing | otherwise -> return $ Just $ Imp.ScalarUse var bt -localMemSize :: VTable ExplicitMemory -> Imp.Count Imp.Bytes Imp.Exp- -> ImpM lore op (Either (Imp.Count Imp.Bytes Imp.Exp) Imp.KernelConstExp)-localMemSize vtable e = isConstExp vtable (Imp.unCount e) >>= \case- Just e' | isStaticExp e' -> return $ Right e'- _ -> return $ Left e- isConstExp :: VTable ExplicitMemory -> Imp.Exp -> ImpM lore op (Maybe Imp.KernelConstExp) isConstExp vtable size = do@@ -523,7 +619,7 @@ onLeaf Imp.Index{} _ = Nothing lookupConstExp name = constExp =<< hasExp =<< M.lookup name vtable- constExp (Op (Inner (GetSize key _))) =+ constExp (Op (Inner (SizeOp (GetSize key _)))) = Just $ LeafExp (Imp.SizeConst $ keyWithEntryPoint fname key) int32 constExp e = primExpFromExp lookupConstExp e return $ replaceInPrimExpM onLeaf size@@ -531,20 +627,6 @@ hasExp (ScalarVar e _) = e hasExp (MemVar e _) = e --- | Only some constant expressions qualify as *static* expressions,--- which we can use for static memory allocation. This is a bit of a--- hack, as it is primarly motivated by what you can put as the size--- when declaring an array in C.-isStaticExp :: Imp.KernelConstExp -> Bool-isStaticExp LeafExp{} = True-isStaticExp ValueExp{} = True-isStaticExp (ConvOpExp ZExt{} x) = isStaticExp x-isStaticExp (ConvOpExp SExt{} x) = isStaticExp x-isStaticExp (BinOpExp Add{} x y) = isStaticExp x && isStaticExp y-isStaticExp (BinOpExp Sub{} x y) = isStaticExp x && isStaticExp y-isStaticExp (BinOpExp Mul{} x y) = isStaticExp x && isStaticExp y-isStaticExp _ = False- computeThreadChunkSize :: SplitOrdering -> Imp.Exp -> Imp.Count Imp.Elements Imp.Exp@@ -950,10 +1032,10 @@ sOp $ Imp.GetGroupId phys_group_id 0 let iterations = (required_groups - Imp.vi32 phys_group_id) `quotRoundingUp` kernelNumGroups constants- i <- newVName "i"- sFor i Int32 iterations $- m =<< dPrimV "virt_group_id" (Imp.vi32 phys_group_id + Imp.vi32 i * kernelNumGroups constants) + sFor "i" iterations $ \i ->+ m =<< dPrimV "virt_group_id" (Imp.vi32 phys_group_id + i * kernelNumGroups constants)+ sKernelThread, sKernelGroup :: String -> Count NumGroups Imp.Exp -> Count GroupSize Imp.Exp -> VName@@ -1115,11 +1197,10 @@ if toExp' int32 per_group_elems == kernelGroupSize constants then sWhen (offset + ltid .<. toExp' int32 w) $ copyDWIMDest dest' [ltid] (Var what) [ltid]- else do- i <- newVName "i"- sFor i Int32 (n `quotRoundingUp` kernelGroupSize constants) $ do+ else+ sFor "i" (n `quotRoundingUp` kernelGroupSize constants) $ \i -> do j <- fmap Imp.vi32 $ dPrimV "j" $- kernelGroupSize constants * Imp.vi32 i + ltid+ kernelGroupSize constants * i + ltid sWhen (j .<. n) $ copyDWIMDest dest' [j] (Var what) [j] where ltid = kernelLocalThreadId constants offset = toExp' int32 per_group_elems * kernelGroupId constants
− src/Futhark/CodeGen/ImpGen/Kernels/SegGenRed.hs
@@ -1,669 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--- | Our compilation strategy for 'SegGenRed' is based around avoiding--- bin conflicts. We do this by splitting the input into chunks, and--- for each chunk computing a single subhistogram. Then we combine--- the subhistograms using an ordinary segmented reduction ('SegRed').------ There are some branches around to efficiently handle the case where--- we use only a single subhistogram (because it's large), so that we--- respect the asymptotics, and do not copy the destination array.------ We also use a heuristic strategy for computing subhistograms in--- local memory when possible. Given:------ H: total size of histograms in bytes, including any lock arrays.------ G: group size------ T: number of bytes of local memory each thread can be given without--- impacting occupancy (determined experimentally, e.g. 32).------ LMAX: maximum amount of local memory per workgroup (hard limit).------ We wish to compute:------ COOP: cooperation level (number of threads per subhistogram)------ LH: number of local memory subhistograms------ We do this as:------ COOP = ceil(H / T)--- LH = ceil((G*T)/H)--- if COOP <= G && H <= LMAX then--- use local memory--- else--- use global memory--module Futhark.CodeGen.ImpGen.Kernels.SegGenRed- ( compileSegGenRed )- where--import Control.Monad.Except-import Data.Either-import Data.Maybe-import Data.List--import Prelude hiding (quot, rem)--import Futhark.MonadFreshNames-import Futhark.Representation.ExplicitMemory-import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun-import Futhark.Pass.ExplicitAllocations()-import qualified Futhark.CodeGen.ImpCode.Kernels as Imp-import Futhark.CodeGen.ImpGen-import Futhark.CodeGen.ImpGen.Kernels.SegRed (compileSegRed')-import Futhark.CodeGen.ImpGen.Kernels.Base-import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem)-import Futhark.Util (chunks, mapAccumLM, splitFromEnd, takeLast)-import Futhark.Construct (fullSliceNum)--i32Toi64 :: PrimExp v -> PrimExp v-i32Toi64 = ConvOpExp (SExt Int32 Int64)--data SubhistosInfo = SubhistosInfo { subhistosArray :: VName- , subhistosAlloc :: CallKernelGen ()- }--data SegGenRedSlug = SegGenRedSlug- { slugOp :: GenReduceOp ExplicitMemory- , slugNumSubhistos :: VName- , slugSubhistos :: [SubhistosInfo]- }---- | Figure out how much memory is needed per histogram, and compute--- some other auxiliary information.-computeHistoUsage :: SegSpace- -> GenReduceOp ExplicitMemory- -> CallKernelGen (Imp.Count Imp.Bytes Imp.Exp, SegGenRedSlug)-computeHistoUsage space op = do- let segment_dims = init $ unSegSpace space- num_segments = length segment_dims-- op_h <- fmap (sum . map typeSize) $ mapM lookupType $ genReduceDest op-- -- Create names for the intermediate array memory blocks,- -- memory block sizes, arrays, and number of subhistograms.- num_subhistos <- dPrim "num_subhistos" int32- subhisto_infos <- forM (zip (genReduceDest op) (genReduceNeutral op)) $ \(dest, ne) -> do- dest_t <- lookupType dest- dest_mem <- entryArrayLocation <$> lookupArray dest-- subhistos_mem <-- sDeclareMem (baseString dest ++ "_subhistos_mem") (Space "device")-- let subhistos_shape = Shape (map snd segment_dims++[Var num_subhistos]) <>- stripDims num_segments (arrayShape dest_t)- subhistos_membind = ArrayIn subhistos_mem $ IxFun.iota $- map (primExpFromSubExp int32) $ shapeDims subhistos_shape- subhistos <- sArray (baseString dest ++ "_subhistos")- (elemType dest_t) subhistos_shape subhistos_membind-- return $ SubhistosInfo subhistos $ do- let unitHistoCase =- emit $- Imp.SetMem subhistos_mem (memLocationName dest_mem) $- Space "device"-- multiHistoCase = do- let num_elems = foldl' (*) (Imp.var num_subhistos int32) $- map (toExp' int32) $ arrayDims dest_t-- let subhistos_mem_size =- Imp.bytes $- Imp.unCount (Imp.elements num_elems `Imp.withElemType` elemType dest_t)-- sAlloc_ subhistos_mem subhistos_mem_size $ Space "device"- sReplicate subhistos (Shape (map snd segment_dims ++- [Var num_subhistos, genReduceWidth op]) <>- genReduceShape op) ne- subhistos_t <- lookupType subhistos- let slice = fullSliceNum (map (toExp' int32) $ arrayDims subhistos_t) $- map (unitSlice 0 . toExp' int32 . snd) segment_dims ++- [DimFix 0]- sUpdate subhistos slice $ Var dest-- sIf (Imp.var num_subhistos int32 .==. 1) unitHistoCase multiHistoCase-- return (op_h, SegGenRedSlug op num_subhistos subhisto_infos)--localMemLockArray :: Count GroupSize SubExp -> Type-localMemLockArray (Count group_size) = Array int32 (Shape [group_size]) NoUniqueness---- | How many bytes will be spent on lock arrays if we use a local--- memory implementation?-localMemLockUsage :: Count GroupSize SubExp -> [SegGenRedSlug] -> Imp.Count Imp.Bytes Imp.Exp-localMemLockUsage group_size slugs =- if any (isRight . atomicUpdateLocking . genReduceOp . slugOp) slugs- then typeSize $ localMemLockArray group_size- else 0--prepareAtomicUpdateGlobal :: Maybe Locking -> [VName] -> SegGenRedSlug- -> CallKernelGen (Maybe Locking,- [Imp.Exp] -> InKernelGen ())-prepareAtomicUpdateGlobal l dests slug =- -- We need a separate lock array if the operators are not all of a- -- particularly simple form that permits pure atomic operations.- case (l, atomicUpdateLocking $ genReduceOp $ slugOp slug) of- (_, Left f) -> return (l, f (Space "global") dests)- (Just l', Right f) -> return (l, f l' (Space "global") dests)- (Nothing, Right f) -> do- -- The number of locks used here is too low, but since we are- -- currently forced to inline a huge list, I'm keeping it down- -- for now. Some quick experiments suggested that it has little- -- impact anyway (maybe the locking case is just too slow).- --- -- A fun solution would also be to use a simple hashing- -- algorithm to ensure good distribution of locks.- let num_locks = 10000- dims = map (toExp' int32) $- shapeDims (genReduceShape (slugOp slug)) ++- [ Var (slugNumSubhistos slug)- , genReduceWidth (slugOp slug)]- locks <-- sStaticArray "genred_locks" (Space "device") int32 $- Imp.ArrayZeros num_locks- let l' = Locking locks 0 1 0 ((`rem` fromIntegral num_locks) . flattenIndex dims)- return (Just l', f l' (Space "global") dests)--prepareIntermediateArraysGlobal :: Imp.Exp -> [SegGenRedSlug]- -> CallKernelGen- [(VName,- [VName],- [Imp.Exp] -> InKernelGen ())]-prepareIntermediateArraysGlobal num_threads = fmap snd . mapAccumLM onOp Nothing- where- onOp l slug@(SegGenRedSlug op num_subhistos subhisto_info) = do- -- Determining the degree of cooperation (heuristic):- -- coop_lvl := size of histogram (Cooperation level)- -- num_histos := (threads / coop_lvl) (Number of histograms)- -- threads := min(physical_threads, segment_size)- --- -- Careful to avoid division by zero when genReduceWidth==0.- num_subhistos <--- num_threads `quotRoundingUp`- BinOpExp (SMax Int32) 1 (toExp' int32 (genReduceWidth op))-- emit $ Imp.DebugPrint "Number of subhistograms in global memory" $- Just (int32, Imp.vi32 num_subhistos)-- -- Initialise sub-histograms.- --- -- If num_subhistos is 1, then we just reuse the original- -- destination. The idea is to avoid a copy if we are writing a- -- small number of values into a very large prior histogram.- dests <- forM (zip (genReduceDest op) subhisto_info) $ \(dest, info) -> do- dest_mem <- entryArrayLocation <$> lookupArray dest-- sub_mem <- fmap memLocationName $- entryArrayLocation <$>- lookupArray (subhistosArray info)-- let unitHistoCase =- emit $- Imp.SetMem sub_mem (memLocationName dest_mem) $- Space "device"-- multiHistoCase = subhistosAlloc info-- sIf (Imp.var num_subhistos int32 .==. 1) unitHistoCase multiHistoCase-- return $ subhistosArray info-- (l', do_op) <- prepareAtomicUpdateGlobal l dests slug-- return (l', (num_subhistos, dests, do_op))--genRedKernelGlobal :: [PatElem ExplicitMemory]- -> Count NumGroups SubExp -> Count GroupSize SubExp- -> SegSpace- -> [SegGenRedSlug]- -> KernelBody ExplicitMemory- -> CallKernelGen ()-genRedKernelGlobal map_pes num_groups group_size space slugs kbody = do- num_groups' <- traverse toExp num_groups- group_size' <- traverse toExp group_size- let (space_is, space_sizes) = unzip $ unSegSpace space- space_sizes_64 = map (i32Toi64 . toExp' int32) space_sizes- total_w_64 = product space_sizes_64- num_threads = unCount num_groups' * unCount group_size'-- histograms <- prepareIntermediateArraysGlobal num_threads slugs-- elems_per_thread_64 <- dPrimV "elems_per_thread_64" $- total_w_64 `quotRoundingUp`- ConvOpExp (SExt Int32 Int64) num_threads-- sKernelThread "seggenred_global" num_groups' group_size' (segFlat space) $ \constants -> do- -- Compute subhistogram index for each thread, per histogram.- subhisto_inds <- forM histograms $ \(num_histograms, _, _) ->- dPrimV "subhisto_ind" $- kernelGlobalThreadId constants `quot`- (kernelNumThreads constants `quotRoundingUp` Imp.var num_histograms int32)-- flat_idx <- newVName "flat_idx"- sFor flat_idx Int64 (Imp.var elems_per_thread_64 int64) $ do- -- Compute the offset into the input and output. To this a- -- thread can add its local ID to figure out which element it is- -- responsible for. The calculation is done with 64-bit- -- integers to avoid overflow, but the final segment indexes are- -- 32 bit.- offset <- dPrimV "offset" $- (i32Toi64 (kernelGroupId constants) *- (Imp.var elems_per_thread_64 int64 *- i32Toi64 (kernelGroupSize constants)))- + (Imp.var flat_idx int64 * i32Toi64 (kernelGroupSize constants))-- j <- dPrimV "j" $ Imp.var offset int64 + i32Toi64 (kernelLocalThreadId constants)-- -- Construct segment indices.- let setIndex v e = do dPrim_ v int32- v <-- e- zipWithM_ setIndex space_is $- map (ConvOpExp (SExt Int64 Int32)) . unflattenIndex space_sizes_64 $ Imp.var j int64-- -- We execute the bucket function once and update each histogram serially.- -- We apply the bucket function if j=offset+ltid is less than- -- num_elements. This also involves writing to the mapout- -- arrays.- let input_in_bounds = Imp.var j int32 .<. total_w_64-- sWhen input_in_bounds $ compileStms mempty (kernelBodyStms kbody) $ do- let (red_res, map_res) = splitFromEnd (length map_pes) $ kernelBodyResult kbody-- sComment "save map-out results" $- forM_ (zip map_pes map_res) $ \(pe, res) ->- copyDWIM (patElemName pe)- (map ((`Imp.var` int32) . fst) $ unSegSpace space)- (kernelResultSubExp res) []-- let (buckets, vs) = splitAt (length slugs) red_res- perOp = chunks $ map (length . genReduceDest . slugOp) slugs-- sComment "perform atomic updates" $- forM_ (zip5 (map slugOp slugs) histograms buckets (perOp vs) subhisto_inds) $- \(GenReduceOp dest_w _ _ shape lam,- (_, _, do_op), bucket, vs', subhisto_ind) -> do-- let bucket' = toExp' int32 $ kernelResultSubExp bucket- dest_w' = toExp' int32 dest_w- bucket_in_bounds = 0 .<=. bucket' .&&. bucket' .<. dest_w'- bucket_is = map (`Imp.var` int32) (init space_is) ++- [Imp.var subhisto_ind int32, bucket']- vs_params = takeLast (length vs') $ lambdaParams lam-- sWhen bucket_in_bounds $ do- dLParams $ lambdaParams lam- sLoopNest shape $ \is -> do- forM_ (zip vs_params vs') $ \(p, res) ->- copyDWIM (paramName p) [] (kernelResultSubExp res) is- do_op (bucket_is ++ is)--prepareIntermediateArraysLocal :: Count NumGroups SubExp -> Count GroupSize SubExp- -> VName -> [SegGenRedSlug]- -> CallKernelGen- [([VName],- KernelConstants ->- InKernelGen ([VName],- [Imp.Exp] -> InKernelGen ()))]-prepareIntermediateArraysLocal num_groups group_size num_subhistos_per_group =- fmap snd . mapAccumLM onOp Nothing- where- onOp l (SegGenRedSlug op num_subhistos subhisto_info) = do-- num_subhistos <-- toExp' int32 (unCount num_groups)-- emit $ Imp.DebugPrint "Number of subhistograms in global memory" $- Just (int32, Imp.vi32 num_subhistos)-- -- Some trickery is afoot here because we need to construct a- -- Locking structure in the CallKernelGen monad, but the actual- -- initialisation of the locks array must happen on the device.- -- Also, we want only one locks array, no matter how many- -- operators need locking.- (l', mk_op) <-- case (l, atomicUpdateLocking $ genReduceOp op) of- (_, Left f) -> return (l, const $ return f)- (Just l', Right f) -> return (l, const $ return $ f l')- (Nothing, Right f) -> do- locks <- newVName "locks"- num_locks <- toExp $ unCount group_size-- let dims = map (toExp' int32) $- Var num_subhistos_per_group :- shapeDims (genReduceShape op) ++- [genReduceWidth op]- l' = Locking locks 0 1 0 ((`rem` num_locks) . flattenIndex dims)- locks_t = localMemLockArray group_size-- mk_op constants = do- locks_mem <- sAlloc "locks_mem" (typeSize locks_t) $ Space "local"- dArray locks int32 (arrayShape locks_t) $- ArrayIn locks_mem $ IxFun.iota $- map (primExpFromSubExp int32) $ arrayDims locks_t-- sComment "All locks start out unlocked" $- copyDWIM locks [kernelLocalThreadId constants] (intConst Int32 0) []-- return $ f l'-- return (Just l', mk_op)-- -- Initialise local-memory sub-histograms. These are- -- represented as two-dimensional arrays.- let init_local_subhistos constants = do- local_subhistos <-- forM (genReduceDest op) $ \dest -> do- dest_t <- lookupType dest-- let sub_local_shape =- Shape [Var num_subhistos_per_group] <> arrayShape dest_t- sAllocArray "subhistogram_local"- (elemType dest_t) sub_local_shape (Space "local")-- do_op <- mk_op constants-- return (local_subhistos, do_op (Space "local") local_subhistos)-- -- Initialise global-memory sub-histograms.- glob_subhistos <- forM subhisto_info $ \info -> do- subhistosAlloc info- return $ subhistosArray info-- return (l', (glob_subhistos, init_local_subhistos))--genRedKernelLocal :: VName- -> [PatElem ExplicitMemory]- -> Count NumGroups SubExp -> Count GroupSize SubExp- -> SegSpace- -> [SegGenRedSlug]- -> KernelBody ExplicitMemory- -> CallKernelGen ()-genRedKernelLocal num_subhistos_per_group_var map_pes num_groups group_size space slugs kbody = do- num_groups' <- traverse toExp num_groups- group_size' <- traverse toExp group_size- let num_threads = unCount num_groups' * unCount group_size'- (space_is, space_sizes) = unzip $ unSegSpace space- segment_dims = init space_sizes- num_segments = length segment_dims- space_sizes_64 = map (i32Toi64 . toExp' int32) space_sizes- total_w_64 = product space_sizes_64- num_subhistos_per_group = Imp.var num_subhistos_per_group_var int32-- emit $ Imp.DebugPrint "Number of local subhistograms per group" $ Just (int32, num_subhistos_per_group)-- init_histograms <- prepareIntermediateArraysLocal num_groups group_size num_subhistos_per_group_var slugs-- elems_per_thread_64 <- dPrimV "elems_per_thread_64" $- total_w_64 `quotRoundingUp`- ConvOpExp (SExt Int32 Int64) num_threads-- sKernelThread "seggenred_local" num_groups' group_size' (segFlat space) $ \constants -> do- histograms <- forM init_histograms $- \(glob_subhistos, init_local_subhistos) -> do- (local_subhistos, do_op) <- init_local_subhistos constants- return (zip glob_subhistos local_subhistos, do_op)-- -- Find index of local subhistograms updated by this thread. We- -- try to ensure, as much as possible, that threads in the same- -- warp use different subhistograms, to avoid conflicts.- thread_local_subhisto_i <-- fmap (`Imp.var` int32) $ dPrimV "thread_local_subhisto_i" $- kernelLocalThreadId constants `rem` num_subhistos_per_group-- let (red_res, map_res) = splitFromEnd (length map_pes) $- map kernelResultSubExp $ kernelBodyResult kbody- (buckets, vs) = splitAt (length slugs) red_res- perOp = chunks $ map (length . genReduceDest . slugOp) slugs-- let onSlugs f = forM_ (zip slugs histograms) $ \(slug, (dests, _)) -> do- let histo_dims =- map (toExp' int32) $- segment_dims ++- genReduceWidth (slugOp slug) : shapeDims (genReduceShape (slugOp slug))- histo_size <- fmap (`Imp.var` int32) $ dPrimV "histo_size" $- product histo_dims- f slug dests histo_dims histo_size-- let onAllHistograms f =- onSlugs $ \slug dests histo_dims histo_size -> do- let group_hists_size = num_subhistos_per_group * histo_size- init_per_thread <- dPrimV "init_per_thread" $- group_hists_size `quotRoundingUp` kernelGroupSize constants-- forM_ (zip dests (genReduceNeutral $ slugOp slug)) $ \((dest_global, dest_local), ne) -> do- i <- newVName "local_i"- sFor i Int32 (Imp.var init_per_thread int32) $ do- j <- fmap (`Imp.var` int32) $ dPrimV "j" $- Imp.var i int32 * kernelGroupSize constants +- kernelLocalThreadId constants- j_offset <- fmap (`Imp.var` int32) $ dPrimV "j_offset" $- num_subhistos_per_group *- histo_size *- kernelGroupId constants + j-- local_subhisto_i <- dPrimV "local_subhisto_i" $ j `quot` histo_size- let bucket_is = unflattenIndex histo_dims $ j `rem` histo_size- global_subhisto_i <- dPrimV "global_subhisto_i" $ j_offset `quot` histo_size-- sWhen (j .<. group_hists_size) $- f dest_local dest_global (slugOp slug) ne- (Imp.var local_subhisto_i int32) (Imp.var global_subhisto_i int32)- bucket_is-- sComment "initialize histograms in local memory" $- onAllHistograms $ \dest_local dest_global op ne local_subhisto_i global_subhisto_i bucket_is ->- sComment "First subhistogram is initialised from global memory; others with neutral element." $ do- let global_is = take num_segments bucket_is ++- [0] ++ drop num_segments bucket_is- local_is = local_subhisto_i : bucket_is- sIf (global_subhisto_i .==. 0)- (copyDWIM dest_local local_is (Var dest_global) global_is)- (sLoopNest (genReduceShape op) $ \is ->- copyDWIM dest_local (local_is++is) ne [])-- sOp Imp.LocalBarrier-- flat_idx <- newVName "flat_idx"- sFor flat_idx Int64 (Imp.var elems_per_thread_64 int64) $ do- -- Compute the offset into the input and output. To this a- -- thread can add its local ID to figure out which element it is- -- responsible for. The calculation is done with 64-bit- -- integers to avoid overflow, but the final segment indexes are- -- 32 bit.- offset <- dPrimV "offset" $- (i32Toi64 (kernelGroupId constants) *- (Imp.var elems_per_thread_64 int64 *- i32Toi64 (kernelGroupSize constants)))- + (Imp.var flat_idx int64 * i32Toi64 (kernelGroupSize constants))-- j <- dPrimV "j" $ Imp.var offset int64 + i32Toi64 (kernelLocalThreadId constants)-- -- Construct segment indices.- zipWithM_ dPrimV_ space_is $- map (ConvOpExp (SExt Int64 Int32)) . unflattenIndex space_sizes_64 $ Imp.var j int64-- -- We execute the bucket function once and update each histogram serially.- -- We apply the bucket function if j=offset+ltid is less than- -- num_elements. This also involves writing to the mapout- -- arrays.- let input_in_bounds = Imp.var j int32 .<. total_w_64-- sWhen input_in_bounds $ compileStms mempty (kernelBodyStms kbody) $ do-- sComment "save map-out results" $- forM_ (zip map_pes map_res) $ \(pe, se) ->- copyDWIM (patElemName pe)- (map (`Imp.var` int32) space_is) se []-- forM_ (zip4 (map slugOp slugs) histograms buckets (perOp vs)) $- \(GenReduceOp dest_w _ _ shape lam,- (_, do_op), bucket, vs') -> do-- let bucket' = toExp' int32 bucket- dest_w' = toExp' int32 dest_w- bucket_in_bounds = 0 .<=. bucket' .&&. bucket' .<. dest_w'- bucket_is = thread_local_subhisto_i :- map (`Imp.var` int32) (init space_is) ++ [bucket']- vs_params = takeLast (length vs') $ lambdaParams lam-- sComment "perform atomic updates" $- sWhen bucket_in_bounds $ do- dLParams $ lambdaParams lam- sLoopNest shape $ \is -> do- forM_ (zip vs_params vs') $ \(p, v) ->- copyDWIM (paramName p) [] v is- do_op (bucket_is ++ is)-- sOp Imp.LocalBarrier- sOp Imp.GlobalBarrier-- sComment "Compact the multiple local memory subhistograms to a single subhistogram result" $- onSlugs $ \slug dests histo_dims histo_size -> do- bins_per_thread <- fmap (`Imp.var` int32) $ dPrimV "init_per_thread" $- histo_size `quotRoundingUp` kernelGroupSize constants-- i <- newVName "local_i"- sFor i Int32 bins_per_thread $ do- j <- fmap (`Imp.var` int32) $ dPrimV "j" $- Imp.var i int32 * kernelGroupSize constants +- kernelLocalThreadId constants- sWhen (j .<. histo_size) $ do- -- We are responsible for compacting the flat bin 'j', which- -- we immediately unflatten.- let bucket_is = unflattenIndex histo_dims j- dLParams $ lambdaParams $ genReduceOp $ slugOp slug- let (xparams, yparams) = splitAt (length local_dests) $- lambdaParams $ genReduceOp $ slugOp slug- local_dests = map snd dests-- sComment "Read values from subhistogram 0." $- forM_ (zip xparams local_dests) $ \(xp, subhisto) ->- copyDWIM- (paramName xp) []- (Var subhisto) (0:bucket_is)-- sComment "Accumulate based on values in other subhistograms." $ do- subhisto_id <- newVName "subhisto_id"- sFor subhisto_id Int32 (num_subhistos_per_group - 1) $ do- forM_ (zip yparams local_dests) $ \(yp, subhisto) ->- copyDWIM- (paramName yp) []- (Var subhisto) (Imp.var subhisto_id int32 + 1 : bucket_is)- compileBody' xparams $ lambdaBody $ genReduceOp $ slugOp slug-- sComment "Put values back in subhistogram 0." $- forM_ (zip xparams local_dests) $ \(xp, subhisto) ->- copyDWIM- subhisto (0:bucket_is)- (Var $ paramName xp) []-- sComment "Copy the first local histogram to global memory." $- onSlugs $ \_slug dests histo_dims histo_size -> do- write_per_thread <- dPrimV "write_per_thread" $- histo_size `quotRoundingUp` kernelGroupSize constants-- forM_ dests $ \(dest_global, dest_local) -> do- i <- newVName "local_i"- sFor i Int32 (Imp.var write_per_thread int32) $ do- j <- fmap (`Imp.var` int32) $ dPrimV "j" $- Imp.var i int32 * kernelGroupSize constants +- kernelLocalThreadId constants-- sWhen (j .<. histo_size) $ do- let bucket_is = unflattenIndex histo_dims $ j `rem` histo_size- global_is = take num_segments bucket_is ++- [kernelGroupId constants] ++- drop num_segments bucket_is- local_is = 0 : bucket_is- copyDWIM dest_global global_is (Var dest_local) local_is---- Most of this function is not the histogram part itself, but rather--- figuring out whether to use a local or global memory strategy, as--- well as collapsing the subhistograms produced (which are always in--- global memory, but their number may vary).-compileSegGenRed :: Pattern ExplicitMemory- -> Count NumGroups SubExp -> Count GroupSize SubExp- -> SegSpace- -> [GenReduceOp ExplicitMemory]- -> KernelBody ExplicitMemory- -> CallKernelGen ()-compileSegGenRed (Pattern _ pes) num_groups group_size space ops kbody = do- group_size' <- traverse toExp group_size-- let num_red_res = length ops + sum (map (length . genReduceNeutral) ops)- (all_red_pes, map_pes) = splitAt num_red_res pes-- let t = 8 * 4- g = unCount group_size'- lmax <- dPrim "lmax" int32- sOp $ Imp.GetSizeMax lmax Imp.SizeLocalMemory-- (op_hs, slugs) <- unzip <$> mapM (computeHistoUsage space) ops- h <- fmap (`Imp.var` int32) $- dPrimV "h" $ Imp.unCount $ sum op_hs- coop <- fmap (`Imp.var` int32) $- dPrimV "coop" $ h `quotRoundingUp` t-- -- Check for emptyness to avoid division-by-zero.- sUnless (h .==. 0) $ do- lh <- dPrimV "lh" $ (g * t) `quotRoundingUp` h-- emit $ Imp.DebugPrint "\n# SegGenRed" Nothing- emit $ Imp.DebugPrint "Cooperation level" $ Just (int32, coop)- emit $ Imp.DebugPrint "Memory per set of subhistograms" $ Just (int32, h)- emit $ Imp.DebugPrint "Desired group size" $ Just (int32, g)-- sIf (Imp.unCount (localMemLockUsage group_size slugs) + h * Imp.vi32 lh- .<=. Imp.vi32 lmax- .&&. coop .<=. g)- (genRedKernelLocal lh map_pes num_groups group_size space slugs kbody)- (genRedKernelGlobal map_pes num_groups group_size space slugs kbody)-- let pes_per_op = chunks (map (length . genReduceDest) ops) all_red_pes-- forM_ (zip3 slugs pes_per_op ops) $ \(slug, red_pes, op) -> do- let num_histos = slugNumSubhistos slug- subhistos = map subhistosArray $ slugSubhistos slug-- let unitHistoCase =- -- This is OK because the memory blocks are at least as- -- large as the ones we are supposed to use for the result.- forM_ (zip red_pes subhistos) $ \(pe, subhisto) -> do- pe_mem <- memLocationName . entryArrayLocation <$>- lookupArray (patElemName pe)- subhisto_mem <- memLocationName . entryArrayLocation <$>- lookupArray subhisto- emit $ Imp.SetMem pe_mem subhisto_mem $ Space "device"-- sIf (Imp.var num_histos int32 .==. 1) unitHistoCase $ do- -- For the segmented reduction, we keep the segment dimensions- -- unchanged. To this, we add two dimensions: one over the number- -- of buckets, and one over the number of subhistograms. This- -- inner dimension is the one that is collapsed in the reduction.- let num_buckets = genReduceWidth op-- bucket_id <- newVName "bucket_id"- subhistogram_id <- newVName "subhistogram_id"- vector_ids <- mapM (const $ newVName "vector_id") $- shapeDims $ genReduceShape op-- flat_gtid <- newVName "flat_gtid"-- let lvl = SegThread num_groups group_size SegVirt- segred_space =- SegSpace flat_gtid $- segment_dims ++- [(bucket_id, num_buckets)] ++- zip vector_ids (shapeDims $ genReduceShape op) ++- [(subhistogram_id, Var num_histos)]-- let segred_op = SegRedOp Commutative (genReduceOp op) (genReduceNeutral op) mempty- compileSegRed' (Pattern [] red_pes) lvl segred_space [segred_op] $ \_ red_cont ->- red_cont $ flip map subhistos $ \subhisto ->- (Var subhisto, map (`Imp.var` int32) $- map fst segment_dims ++ [subhistogram_id, bucket_id] ++ vector_ids)-- where segment_dims = init $ unSegSpace space
+ src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs view
@@ -0,0 +1,875 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Our compilation strategy for 'SegHist' is based around avoiding+-- bin conflicts. We do this by splitting the input into chunks, and+-- for each chunk computing a single subhistogram. Then we combine+-- the subhistograms using an ordinary segmented reduction ('SegRed').+--+-- There are some branches around to efficiently handle the case where+-- we use only a single subhistogram (because it's large), so that we+-- respect the asymptotics, and do not copy the destination array.+--+-- We also use a heuristic strategy for computing subhistograms in+-- local memory when possible. Given:+--+-- H: total size of histograms in bytes, including any lock arrays.+--+-- G: group size+--+-- T: number of bytes of local memory each thread can be given without+-- impacting occupancy (determined experimentally, e.g. 32).+--+-- LMAX: maximum amount of local memory per workgroup (hard limit).+--+-- We wish to compute:+--+-- COOP: cooperation level (number of threads per subhistogram)+--+-- LH: number of local memory subhistograms+--+-- We do this as:+--+-- COOP = ceil(H / T)+-- LH = ceil((G*T)/H)+-- if COOP <= G && H <= LMAX then+-- use local memory+-- else+-- use global memory++module Futhark.CodeGen.ImpGen.Kernels.SegHist+ ( compileSegHist )+ where++import Control.Monad.Except+import Data.Maybe+import Data.List++import Prelude hiding (quot, rem)++import Futhark.MonadFreshNames+import Futhark.Representation.ExplicitMemory+import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun+import Futhark.Pass.ExplicitAllocations()+import qualified Futhark.CodeGen.ImpCode.Kernels as Imp+import Futhark.CodeGen.ImpGen+import Futhark.CodeGen.ImpGen.Kernels.SegRed (compileSegRed')+import Futhark.CodeGen.ImpGen.Kernels.Base+import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem)+import Futhark.Util (chunks, mapAccumLM, splitFromEnd, takeLast)+import Futhark.Construct (fullSliceNum)++i32Toi64 :: PrimExp v -> PrimExp v+i32Toi64 = ConvOpExp (SExt Int32 Int64)++data SubhistosInfo = SubhistosInfo { subhistosArray :: VName+ , subhistosAlloc :: CallKernelGen ()+ }++data SegHistSlug = SegHistSlug+ { slugOp :: HistOp ExplicitMemory+ , slugNumSubhistos :: VName+ , slugSubhistos :: [SubhistosInfo]+ , slugAtomicUpdate :: AtomicUpdate ExplicitMemory+ }++histoSpaceUsage :: HistOp ExplicitMemory+ -> Imp.Count Imp.Bytes Imp.Exp+histoSpaceUsage op =+ sum $+ map (typeSize .+ (`arrayOfRow` histWidth op) .+ (`arrayOfShape` histShape op)) $+ lambdaReturnType $ histOp op++-- | Figure out how much memory is needed per histogram, both+-- segmented and unsegmented,, and compute some other auxiliary+-- information.+computeHistoUsage :: SegSpace+ -> HistOp ExplicitMemory+ -> CallKernelGen (Imp.Count Imp.Bytes Imp.Exp,+ Imp.Count Imp.Bytes Imp.Exp,+ SegHistSlug)+computeHistoUsage space op = do+ let segment_dims = init $ unSegSpace space+ num_segments = length segment_dims++ -- Create names for the intermediate array memory blocks,+ -- memory block sizes, arrays, and number of subhistograms.+ num_subhistos <- dPrim "num_subhistos" int32+ subhisto_infos <- forM (zip (histDest op) (histNeutral op)) $ \(dest, ne) -> do+ dest_t <- lookupType dest+ dest_mem <- entryArrayLocation <$> lookupArray dest++ subhistos_mem <-+ sDeclareMem (baseString dest ++ "_subhistos_mem") (Space "device")++ let subhistos_shape = Shape (map snd segment_dims++[Var num_subhistos]) <>+ stripDims num_segments (arrayShape dest_t)+ subhistos_membind = ArrayIn subhistos_mem $ IxFun.iota $+ map (primExpFromSubExp int32) $ shapeDims subhistos_shape+ subhistos <- sArray (baseString dest ++ "_subhistos")+ (elemType dest_t) subhistos_shape subhistos_membind++ return $ SubhistosInfo subhistos $ do+ let unitHistoCase =+ emit $+ Imp.SetMem subhistos_mem (memLocationName dest_mem) $+ Space "device"++ multiHistoCase = do+ let num_elems = foldl' (*) (Imp.var num_subhistos int32) $+ map (toExp' int32) $ arrayDims dest_t++ let subhistos_mem_size =+ Imp.bytes $+ Imp.unCount (Imp.elements num_elems `Imp.withElemType` elemType dest_t)++ sAlloc_ subhistos_mem subhistos_mem_size $ Space "device"+ sReplicate subhistos (Shape (map snd segment_dims +++ [Var num_subhistos, histWidth op]) <>+ histShape op) ne+ subhistos_t <- lookupType subhistos+ let slice = fullSliceNum (map (toExp' int32) $ arrayDims subhistos_t) $+ map (unitSlice 0 . toExp' int32 . snd) segment_dims +++ [DimFix 0]+ sUpdate subhistos slice $ Var dest++ sIf (Imp.var num_subhistos int32 .==. 1) unitHistoCase multiHistoCase++ let h = histoSpaceUsage op+ segmented_h = h * product (map (Imp.bytes . toExp' int32) $ init $ segSpaceDims space)++ return (h,+ segmented_h,+ SegHistSlug op num_subhistos subhisto_infos $+ atomicUpdateLocking $ histOp op)++prepareAtomicUpdateGlobal :: Maybe Locking -> [VName] -> SegHistSlug+ -> CallKernelGen (Maybe Locking,+ [Imp.Exp] -> InKernelGen ())+prepareAtomicUpdateGlobal l dests slug =+ -- We need a separate lock array if the operators are not all of a+ -- particularly simple form that permits pure atomic operations.+ case (l, slugAtomicUpdate slug) of+ (_, AtomicPrim f) -> return (l, f (Space "global") dests)+ (_, AtomicCAS f) -> return (l, f (Space "global") dests)+ (Just l', AtomicLocking f) -> return (l, f l' (Space "global") dests)+ (Nothing, AtomicLocking f) -> do+ -- The number of locks used here is too low, but since we are+ -- currently forced to inline a huge list, I'm keeping it down+ -- for now. Some quick experiments suggested that it has little+ -- impact anyway (maybe the locking case is just too slow).+ --+ -- A fun solution would also be to use a simple hashing+ -- algorithm to ensure good distribution of locks.+ let num_locks = 10000+ dims = map (toExp' int32) $+ shapeDims (histShape (slugOp slug)) +++ [ Var (slugNumSubhistos slug)+ , histWidth (slugOp slug)]+ locks <-+ sStaticArray "hist_locks" (Space "device") int32 $+ Imp.ArrayZeros num_locks+ let l' = Locking locks 0 1 0 (pure . (`rem` fromIntegral num_locks) . flattenIndex dims)+ return (Just l', f l' (Space "global") dests)++infoPrints :: Imp.Exp -> VName -> Imp.Exp -> ImpM lore op ()+infoPrints hist_H hist_M hist_C = do+ emit $ Imp.DebugPrint "Histogram size (H)" $ Just hist_H+ emit $ Imp.DebugPrint "Multiplication degree (M)" $ Just $ Imp.vi32 hist_M+ emit $ Imp.DebugPrint "Cooperation level (C)" $ Just hist_C++prepareIntermediateArraysGlobal :: Imp.Exp -> Imp.Exp -> [SegHistSlug]+ -> CallKernelGen+ [(VName,+ [VName],+ [Imp.Exp] -> InKernelGen ())]+prepareIntermediateArraysGlobal hist_T hist_N =+ fmap snd . mapAccumLM onOp Nothing+ where+ onOp l slug@(SegHistSlug op num_subhistos subhisto_info do_op) = do+ hist_H <- toExp $ histWidth op++ hist_u <- dPrimVE "hist_u" $+ case do_op of+ AtomicPrim{} -> 1+ _ -> 2++ hist_RF <- toExp $ histRaceFactor op++ let hist_k_RF = 0.75+ hist_L2 = 16384+ hist_L2_ln_sz = 64+ hist_F_L2 = 0.4++ let r64 = ConvOpExp (SIToFP Int32 Float64)+ t64 = ConvOpExp (FPToSI Float64 Int32)++ let hist_el_size =+ case do_op of+ AtomicLocking{} ->+ unCount+ (sum $ map (typeSize . (`arrayOfShape` histShape op)) $+ Prim int32 : lambdaReturnType (histOp op))+ `quot` genericLength (lambdaReturnType (histOp op))+ _ ->+ unCount $ sum $+ map (typeSize . (`arrayOfShape` histShape op)) $+ lambdaReturnType (histOp op)++ hist_RACE_exp <- dPrimVE "hist_RACE_exp" $+ Imp.BinOpExp (FMax Float64) 1 $+ (hist_k_RF * r64 hist_RF) /+ Imp.BinOpExp (FMin Float64) 1 (r64 hist_L2_ln_sz / r64 hist_el_size)++ -- Hardcode a single pass for now.+ let hist_S = 1++ hist_H_chk <- dPrimVE "hist_H_chk" $+ hist_H `quotRoundingUp` hist_S+++ hist_k_max <- dPrimVE "hist_k_max" $+ Imp.BinOpExp (SMin Int32)+ (t64 (hist_F_L2 * hist_L2 * hist_RACE_exp)) hist_N+ `quotRoundingUp` hist_T++ hist_C <- dPrimVE "hist_C" $+ Imp.BinOpExp (SMin Int32) hist_T $+ (hist_u * hist_H_chk) `quotRoundingUp` hist_k_max++ -- Minimal sequential chunking factor.+ let q_small = 2+ work_asymp_M_max <- dPrimVE "work_asymp_M_max" $+ hist_N `quot` (q_small * hist_H)++ let glb_k_min = 2+ coop_min <- dPrimVE "coop_min" $+ Imp.BinOpExp (SMin Int32) hist_T $ hist_H `quot` glb_k_min++ hist_M_min <- dPrimVE "hist_M_min" $+ Imp.BinOpExp (SMax Int32) 1 $+ Imp.BinOpExp (SMin Int32) work_asymp_M_max $+ hist_T `quot` coop_min++ -- Number of subhistograms per result histogram.+ hist_M <- dPrimV "hist_M" $+ Imp.BinOpExp (SMin Int32) hist_M_min $+ Imp.BinOpExp (SMax Int32) 1 $ hist_T `quot` hist_C++ -- num_subhistos is the variable we use to communicate back.+ num_subhistos <-- Imp.vi32 hist_M++ -- Initialise sub-histograms.+ --+ -- If hist_M is 1, then we just reuse the original+ -- destination. The idea is to avoid a copy if we are writing a+ -- small number of values into a very large prior histogram.+ dests <- forM (zip (histDest op) subhisto_info) $ \(dest, info) -> do+ dest_mem <- entryArrayLocation <$> lookupArray dest++ sub_mem <- fmap memLocationName $+ entryArrayLocation <$>+ lookupArray (subhistosArray info)++ let unitHistoCase =+ emit $+ Imp.SetMem sub_mem (memLocationName dest_mem) $+ Space "device"++ multiHistoCase = subhistosAlloc info++ sIf (Imp.var hist_M int32 .==. 1) unitHistoCase multiHistoCase++ return $ subhistosArray info++ (l', do_op') <- prepareAtomicUpdateGlobal l dests slug++ return (l', (hist_M, dests, do_op'))++histKernelGlobal :: [PatElem ExplicitMemory]+ -> Count NumGroups SubExp -> Count GroupSize SubExp+ -> SegSpace+ -> [SegHistSlug]+ -> KernelBody ExplicitMemory+ -> CallKernelGen ()+histKernelGlobal map_pes num_groups group_size space slugs kbody = do+ num_groups' <- traverse toExp num_groups+ group_size' <- traverse toExp group_size+ let (space_is, space_sizes) = unzip $ unSegSpace space+ space_sizes_64 = map (i32Toi64 . toExp' int32) space_sizes+ total_w_64 = product space_sizes_64+ num_threads = unCount num_groups' * unCount group_size'++ emit $ Imp.DebugPrint "## Using global memory" Nothing++ histograms <-+ prepareIntermediateArraysGlobal num_threads+ (toExp' int32 $ last space_sizes) slugs++ elems_per_thread_64 <- dPrimVE "elems_per_thread_64" $+ total_w_64 `quotRoundingUp`+ ConvOpExp (SExt Int32 Int64) num_threads++ sKernelThread "seghist_global" num_groups' group_size' (segFlat space) $ \constants -> do+ -- Compute subhistogram index for each thread, per histogram.+ subhisto_inds <- forM histograms $ \(num_histograms, _, _) ->+ dPrimVE "subhisto_ind" $+ kernelGlobalThreadId constants `quot`+ (kernelNumThreads constants `quotRoundingUp` Imp.var num_histograms int32)++ sFor "flat_idx" elems_per_thread_64 $ \flat_idx -> do+ -- Compute the offset into the input and output. To this a+ -- thread can add its local ID to figure out which element it is+ -- responsible for. The calculation is done with 64-bit+ -- integers to avoid overflow, but the final segment indexes are+ -- 32 bit.+ offset <- dPrimVE "offset" $+ (i32Toi64 (kernelGroupId constants) *+ (elems_per_thread_64 *+ i32Toi64 (kernelGroupSize constants)))+ + (flat_idx * i32Toi64 (kernelGroupSize constants))++ j <- dPrimVE "j" $ offset + i32Toi64 (kernelLocalThreadId constants)++ -- Construct segment indices.+ let setIndex v e = do dPrim_ v int32+ v <-- e+ zipWithM_ setIndex space_is $+ map (ConvOpExp (SExt Int64 Int32)) $ unflattenIndex space_sizes_64 j++ -- We execute the bucket function once and update each histogram serially.+ -- We apply the bucket function if j=offset+ltid is less than+ -- num_elements. This also involves writing to the mapout+ -- arrays.+ let input_in_bounds = j .<. total_w_64++ sWhen input_in_bounds $ compileStms mempty (kernelBodyStms kbody) $ do+ let (red_res, map_res) = splitFromEnd (length map_pes) $ kernelBodyResult kbody++ sComment "save map-out results" $+ forM_ (zip map_pes map_res) $ \(pe, res) ->+ copyDWIM (patElemName pe)+ (map (Imp.vi32 . fst) $ unSegSpace space)+ (kernelResultSubExp res) []++ let (buckets, vs) = splitAt (length slugs) red_res+ perOp = chunks $ map (length . histDest . slugOp) slugs++ sComment "perform atomic updates" $+ forM_ (zip5 (map slugOp slugs) histograms buckets (perOp vs) subhisto_inds) $+ \(HistOp dest_w _ _ _ shape lam,+ (_, _, do_op), bucket, vs', subhisto_ind) -> do++ let bucket' = toExp' int32 $ kernelResultSubExp bucket+ dest_w' = toExp' int32 dest_w+ bucket_in_bounds = 0 .<=. bucket' .&&. bucket' .<. dest_w'+ bucket_is = map Imp.vi32 (init space_is) +++ [subhisto_ind, bucket']+ vs_params = takeLast (length vs') $ lambdaParams lam++ sWhen bucket_in_bounds $ do+ dLParams $ lambdaParams lam+ sLoopNest shape $ \is -> do+ forM_ (zip vs_params vs') $ \(p, res) ->+ copyDWIM (paramName p) [] (kernelResultSubExp res) is+ do_op (bucket_is ++ is)++prepareIntermediateArraysLocal :: VName+ -> Count NumGroups SubExp+ -> SegSpace -> [SegHistSlug]+ -> CallKernelGen+ [([VName],+ KernelConstants ->+ InKernelGen ([VName],+ [Imp.Exp] -> InKernelGen ()))]+prepareIntermediateArraysLocal num_subhistos_per_group num_groups space =+ mapM onOp+ where+ onOp (SegHistSlug op num_subhistos subhisto_info do_op) = do++ -- For the segmented case we produce a single histogram per group.+ if length (unSegSpace space) > 1+ then num_subhistos <-- 1+ else num_subhistos <-- toExp' int32 (unCount num_groups)++ emit $ Imp.DebugPrint "Number of subhistograms in global memory" $+ Just $ Imp.vi32 num_subhistos++ mk_op <-+ case do_op of+ AtomicPrim f -> return $ const $ return f+ AtomicCAS f -> return $ const $ return f+ AtomicLocking f -> do++ let lock_shape =+ Shape $ Var num_subhistos_per_group :+ shapeDims (histShape op) +++ [histWidth op]++ dims <- mapM toExp $ shapeDims lock_shape++ return $ \constants -> do+ locks <- sAllocArray "locks" int32 lock_shape $ Space "local"++ sComment "All locks start out unlocked" $+ groupCoverSpace constants dims $ \is ->+ copyDWIM locks is (intConst Int32 0) []++ return $ f $ Locking locks 0 1 0 id++ -- Initialise local-memory sub-histograms. These are+ -- represented as two-dimensional arrays.+ let init_local_subhistos constants = do+ local_subhistos <-+ forM (histType op) $ \t -> do+ let sub_local_shape =+ Shape [Var num_subhistos_per_group] <> arrayShape t+ sAllocArray "subhistogram_local"+ (elemType t) sub_local_shape (Space "local")++ do_op' <- mk_op constants++ return (local_subhistos, do_op' (Space "local") local_subhistos)++ -- Initialise global-memory sub-histograms.+ glob_subhistos <- forM subhisto_info $ \info -> do+ subhistosAlloc info+ return $ subhistosArray info++ return (glob_subhistos, init_local_subhistos)++histKernelLocal :: VName -> Count NumGroups Imp.Exp+ -> [PatElem ExplicitMemory]+ -> Count NumGroups SubExp -> Count GroupSize SubExp+ -> SegSpace+ -> [SegHistSlug]+ -> KernelBody ExplicitMemory+ -> CallKernelGen ()+histKernelLocal num_subhistos_per_group_var groups_per_segment map_pes num_groups group_size space slugs kbody = do+ num_groups' <- traverse toExp num_groups+ group_size' <- traverse toExp group_size+ let (space_is, space_sizes) = unzip $ unSegSpace space+ segment_is = init space_is+ segment_dims = init space_sizes+ (i_in_segment, segment_size) = last $ unSegSpace space+ num_subhistos_per_group = Imp.var num_subhistos_per_group_var int32++ segment_size' <- toExp segment_size++ emit $ Imp.DebugPrint "Number of local subhistograms per group" $ Just num_subhistos_per_group++ init_histograms <-+ prepareIntermediateArraysLocal num_subhistos_per_group_var num_groups space slugs++ num_segments <- dPrimVE "num_segments" $+ product $ map (toExp' int32) segment_dims++ sKernelThread "seghist_local" num_groups' group_size' (segFlat space) $ \constants ->+ virtualiseGroups constants SegVirt (unCount groups_per_segment * num_segments) $ \group_id_var -> do++ let group_id = Imp.vi32 group_id_var++ flat_segment_id <- dPrimVE "flat_segment_id" $ group_id `quot` unCount groups_per_segment+ gid_in_segment <- dPrimVE "gid_in_segment" $ group_id `rem` unCount groups_per_segment+ -- This pgtid is kind of a "virtualised physical" gtid - not the+ -- same thing as the gtid used for the SegHist itself.+ pgtid_in_segment <- dPrimVE "pgtid_in_segment" $+ gid_in_segment * kernelGroupSize constants + kernelLocalThreadId constants+ threads_per_segment <- dPrimVE "threads_per_segment" $+ unCount groups_per_segment * kernelGroupSize constants++ -- Set segment indices.+ zipWithM_ dPrimV_ segment_is $+ unflattenIndex (map (toExp' int32) segment_dims) flat_segment_id++ histograms <- forM init_histograms $+ \(glob_subhistos, init_local_subhistos) -> do+ (local_subhistos, do_op) <- init_local_subhistos constants+ return (zip glob_subhistos local_subhistos, do_op)++ -- Find index of local subhistograms updated by this thread. We+ -- try to ensure, as much as possible, that threads in the same+ -- warp use different subhistograms, to avoid conflicts.+ thread_local_subhisto_i <-+ dPrimVE "thread_local_subhisto_i" $+ kernelLocalThreadId constants `rem` num_subhistos_per_group++ let (red_res, map_res) = splitFromEnd (length map_pes) $+ map kernelResultSubExp $ kernelBodyResult kbody+ (buckets, vs) = splitAt (length slugs) red_res+ perOp = chunks $ map (length . histDest . slugOp) slugs++ let onSlugs f = forM_ (zip slugs histograms) $ \(slug, (dests, _)) -> do+ let histo_dims = map (toExp' int32) $ histWidth (slugOp slug) :+ shapeDims (histShape (slugOp slug))+ histo_size <- dPrimVE "histo_size" $ product histo_dims+ f slug dests histo_dims histo_size++ let onAllHistograms f =+ onSlugs $ \slug dests histo_dims histo_size -> do+ let group_hists_size = num_subhistos_per_group * histo_size+ init_per_thread <- dPrimVE "init_per_thread" $+ group_hists_size `quotRoundingUp`+ kernelGroupSize constants++ forM_ (zip dests (histNeutral $ slugOp slug)) $+ \((dest_global, dest_local), ne) ->+ sFor "local_i" init_per_thread $ \i -> do+ j <- dPrimVE "j" $+ i * kernelGroupSize constants ++ kernelLocalThreadId constants+ j_offset <- dPrimVE "j_offset" $+ num_subhistos_per_group * histo_size * gid_in_segment + j++ local_subhisto_i <- dPrimVE "local_subhisto_i" $ j `quot` histo_size+ let bucket_is = unflattenIndex histo_dims $ j `rem` histo_size+ global_subhisto_i <- dPrimVE "global_subhisto_i" $ j_offset `quot` histo_size++ sWhen (j .<. group_hists_size) $+ f dest_local dest_global (slugOp slug) ne+ local_subhisto_i global_subhisto_i+ bucket_is++ sComment "initialize histograms in local memory" $+ onAllHistograms $ \dest_local dest_global op ne local_subhisto_i global_subhisto_i bucket_is ->+ sComment "First subhistogram is initialised from global memory; others with neutral element." $ do+ let global_is = map Imp.vi32 segment_is ++ [0] ++ bucket_is+ local_is = local_subhisto_i : bucket_is+ sIf (global_subhisto_i .==. 0)+ (copyDWIM dest_local local_is (Var dest_global) global_is)+ (sLoopNest (histShape op) $ \is ->+ copyDWIM dest_local (local_is++is) ne [])++ sOp Imp.LocalBarrier++ kernelLoop pgtid_in_segment threads_per_segment segment_size' $ \ie -> do+ dPrimV_ i_in_segment ie++ -- We execute the bucket function once and update each histogram+ -- serially. This also involves writing to the mapout arrays.++ compileStms mempty (kernelBodyStms kbody) $ do++ sComment "save map-out results" $+ forM_ (zip map_pes map_res) $ \(pe, se) ->+ copyDWIM (patElemName pe)+ (map Imp.vi32 space_is) se []++ forM_ (zip4 (map slugOp slugs) histograms buckets (perOp vs)) $+ \(HistOp dest_w _ _ _ shape lam,+ (_, do_op), bucket, vs') -> do++ let bucket' = toExp' int32 bucket+ dest_w' = toExp' int32 dest_w+ bucket_in_bounds = 0 .<=. bucket' .&&. bucket' .<. dest_w'+ bucket_is = [thread_local_subhisto_i, bucket']+ vs_params = takeLast (length vs') $ lambdaParams lam++ sComment "perform atomic updates" $+ sWhen bucket_in_bounds $ do+ dLParams $ lambdaParams lam+ sLoopNest shape $ \is -> do+ forM_ (zip vs_params vs') $ \(p, v) ->+ copyDWIM (paramName p) [] v is+ do_op (bucket_is ++ is)++ sOp Imp.LocalBarrier+ sOp Imp.GlobalBarrier++ sComment "Compact the multiple local memory subhistograms to result in global memory" $+ onSlugs $ \slug dests histo_dims histo_size -> do+ bins_per_thread <- dPrimVE "init_per_thread" $+ histo_size `quotRoundingUp` kernelGroupSize constants++ sFor "local_i" bins_per_thread $ \i -> do+ j <- dPrimVE "j" $+ i * kernelGroupSize constants + kernelLocalThreadId constants+ sWhen (j .<. histo_size) $ do+ -- We are responsible for compacting the flat bin 'j', which+ -- we immediately unflatten.+ let bucket_is = unflattenIndex histo_dims j+ dLParams $ lambdaParams $ histOp $ slugOp slug+ let (xparams, yparams) = splitAt (length local_dests) $+ lambdaParams $ histOp $ slugOp slug+ (global_dests, local_dests) = unzip dests++ sComment "Read values from subhistogram 0." $+ forM_ (zip xparams local_dests) $ \(xp, subhisto) ->+ copyDWIM+ (paramName xp) []+ (Var subhisto) (0:bucket_is)++ sComment "Accumulate based on values in other subhistograms." $+ sFor "subhisto_id" (num_subhistos_per_group - 1) $ \subhisto_id -> do+ forM_ (zip yparams local_dests) $ \(yp, subhisto) ->+ copyDWIM+ (paramName yp) []+ (Var subhisto) (subhisto_id + 1 : bucket_is)+ compileBody' xparams $ lambdaBody $ histOp $ slugOp slug++ sComment "Put final bucket value in global memory." $ do+ let global_is = map Imp.vi32 segment_is +++ [group_id `rem` unCount groups_per_segment] +++ bucket_is+ forM_ (zip xparams global_dests) $ \(xp, global_dest) ->+ copyDWIM global_dest global_is (Var $ paramName xp) []++localMemoryCase :: [PatElem ExplicitMemory]+ -> Count NumGroups SubExp -> Count GroupSize SubExp+ -> SegSpace+ -> Imp.Exp -> Imp.Exp -> Imp.Exp -> Imp.Exp+ -> [SegHistSlug]+ -> KernelBody ExplicitMemory+ -> CallKernelGen (Imp.Exp, ImpM ExplicitMemory Imp.HostOp ())+localMemoryCase map_pes num_groups group_size space hist_H hist_el_size hist_N hist_RF slugs kbody = do+ num_groups' <- traverse toExp num_groups+ group_size' <- traverse toExp group_size++ -- Maximum group size (or actual, in this case).+ let hist_B = unCount group_size'+ space_sizes = segSpaceDims space+ segment_dims = init space_sizes+ segmented = not $ null segment_dims++ hist_L <- dPrim "hist_L" int32+ sOp $ Imp.GetSizeMax hist_L Imp.SizeLocalMemory++ let r64 = ConvOpExp (SIToFP Int32 Float64)+ t64 = ConvOpExp (FPToSI Float64 Int32)+ f64ceil x = t64 $ FunExp "round64" [x] $ FloatType Float64++ -- M approximation.+ hist_m' <- dPrimVE "hist_m_prime" $+ r64 (Imp.BinOpExp (SMin Int32)+ (Imp.vi32 hist_L `quot` hist_el_size)+ (hist_N `quotRoundingUp` unCount num_groups'))+ / r64 hist_H++ hist_m <- dPrimVE "hist_m" $+ Imp.BinOpExp (FMax Float64) (r64 1) hist_m'++ -- FIXME: query the lockstep width at runtime.+ hist_W <- dPrimVE "hist_W" 32++ hist_RFC <- dPrimVE "hist_RFC" $+ Imp.BinOpExp (FMin Float64) (r64 hist_RF) $+ r64 hist_W * Imp.BinOpExp (FPow Float64) (r64 hist_RF / r64 hist_W) (1.0 / 3.0)++ hist_f' <- dPrimVE "hist_f_prime" $+ (r64 hist_B * hist_RFC) /+ (hist_m * hist_m * r64 hist_H)++ let casOp AtomicCAS{} = True+ casOp _ = False+ lockOp AtomicLocking{} = True+ lockOp _ = False++ hwdCase =+ dPrimVE "hist_M0" $+ Imp.BinOpExp (SMax Int32) 1 $+ Imp.BinOpExp (SMin Int32) (t64 hist_m') hist_B++ casCase = do+ hist_f_cas <- dPrimVE "hist_f_cas" $ Imp.BinOpExp (SMax Int32) 1 $ f64ceil hist_f'+ dPrimVE "hist_M0" $+ Imp.BinOpExp (SMax Int32) 1 $+ Imp.BinOpExp (SMin Int32) (t64 $ hist_m * r64 hist_f_cas) hist_B++ lockCase = do+ hist_f_cas <- dPrimVE "hist_f_lock" $ Imp.BinOpExp (SMax Int32) 1 $ f64ceil hist_f'+ dPrimVE "hist_M0" $+ Imp.BinOpExp (SMax Int32) 1 $+ Imp.BinOpExp (SMin Int32) (t64 $ hist_m' * r64 hist_f_cas) hist_B++ -- M in the paper, but not adjusted for asymptotic efficiency.+ hist_M0 <-+ if any (lockOp . slugAtomicUpdate) slugs+ then lockCase+ else if any (casOp . slugAtomicUpdate) slugs+ then casCase+ else hwdCase++ -- Minimal sequential chunking factor.+ let q_small = 2++ hist_Nout <- dPrimVE "hist_Nout" $+ product $ map (toExp' int32) segment_dims++ hist_Nin <- dPrimVE "hist_Nin" $ toExp' int32 $ last space_sizes++ -- Maximum M for work efficiency.+ work_asymp_M_max <-+ if segmented then do++ hist_T <- dPrimVE "hist_T" $ unCount num_groups' * unCount group_size'++ hist_T_hist_min <- dPrimVE "hist_T_hist_min" $+ Imp.BinOpExp (SMin Int32) (hist_Nin * hist_Nout) hist_T+ `quotRoundingUp`+ hist_Nout++ -- Number of groups, rounded up.+ let r = hist_T_hist_min `quotRoundingUp` hist_B++ dPrimVE "work_asymp_M_max" $ hist_Nin `quot` (r * hist_H)++ else dPrimVE "work_asymp_M_max" $+ (hist_Nout * hist_N) `quot`+ ((q_small * unCount num_groups' * hist_H)+ `quot` genericLength slugs)++ -- Number of subhistograms per result histogram.+ hist_M <- dPrimV "hist_M" $+ Imp.BinOpExp (SMin Int32) hist_M0 work_asymp_M_max++ -- hist_M may be zero (which we'll check for below), but we need it+ -- for some divisions first, so crudely make a nonzero form.+ let hist_M_nonzero = Imp.BinOpExp (SMax Int32) 1 $ Imp.vi32 hist_M++ -- "Cooperation factor" - the number of threads cooperatively+ -- working on the same (sub)histogram.+ hist_C <- dPrimVE "hist_C" $+ hist_B `quotRoundingUp` hist_M_nonzero++ emit $ Imp.DebugPrint "local hist_M0" $ Just hist_M0+ emit $ Imp.DebugPrint "local work asymp M max" $ Just work_asymp_M_max+ emit $ Imp.DebugPrint "local C" $ Just hist_C+ emit $ Imp.DebugPrint "local B" $ Just hist_B+ emit $ Imp.DebugPrint "local M" $ Just $ Imp.vi32 hist_M+ emit $ Imp.DebugPrint "local memory needed" $+ Just $ hist_H * hist_el_size * Imp.vi32 hist_M++ -- We only use local memory if the number of updates per histogram+ -- at least matches the histogram size, as otherwise it is not+ -- asymptotically efficient. This mostly matters for the segmented+ -- case.+ let pick_local =+ hist_Nin .>=. hist_H+ .&&. (hist_H * hist_el_size * Imp.vi32 hist_M+ .<=. Imp.vi32 hist_L)+ .&&. hist_C .<=. hist_B+ .&&. Imp.vi32 hist_M .>. 0++ groups_per_segment+ | segmented = 1+ | otherwise = num_groups'++ run = do+ emit $ Imp.DebugPrint "## Using local memory" Nothing+ infoPrints hist_H hist_M hist_C+ histKernelLocal hist_M groups_per_segment map_pes num_groups group_size space slugs kbody++ return (pick_local, run)++-- Most of this function is not the histogram part itself, but rather+-- figuring out whether to use a local or global memory strategy, as+-- well as collapsing the subhistograms produced (which are always in+-- global memory, but their number may vary).+compileSegHist :: Pattern ExplicitMemory+ -> Count NumGroups SubExp -> Count GroupSize SubExp+ -> SegSpace+ -> [HistOp ExplicitMemory]+ -> KernelBody ExplicitMemory+ -> CallKernelGen ()+compileSegHist (Pattern _ pes) num_groups group_size space ops kbody = do+ group_size' <- traverse toExp group_size++ dims <- mapM toExp $ segSpaceDims space++ let num_red_res = length ops + sum (map (length . histNeutral) ops)+ (all_red_pes, map_pes) = splitAt num_red_res pes+ segment_size = last dims++ (op_hs, op_seg_hs, slugs) <- unzip3 <$> mapM (computeHistoUsage space) ops+ h <- dPrimVE "h" $ Imp.unCount $ sum op_hs+ seg_h <- dPrimVE "seg_h" $ Imp.unCount $ sum op_seg_hs++ -- Maximum group size (or actual, in this case).+ let hist_B = unCount group_size'++ -- Size of a histogram.+ hist_H <- dPrimVE "hist_H" $ sum $ map (toExp' int32 . histWidth) ops++ -- Size of a single histogram element. Actually the weighted+ -- average of histogram elements in cases where we have more than+ -- one histogram operation, plus any locks.+ let lockSize slug = case slugAtomicUpdate slug of+ AtomicLocking{} -> Just $ primByteSize int32+ _ -> Nothing+ hist_el_size <- dPrimVE "hist_el_size" $ foldl' (+) (h `quotRoundingUp` hist_H) $+ mapMaybe lockSize slugs++ -- Input elements contributing to each histogram.+ hist_N <- dPrimVE "hist_N" segment_size++ -- Compute RF as the average RF over all the histograms.+ hist_RF <- dPrimVE "hist_RF" $+ sum (map (toExp' int32. histRaceFactor . slugOp) slugs)+ `quot`+ genericLength slugs++ -- Check for emptyness to avoid division-by-zero.+ sUnless (seg_h .==. 0) $ do++ emit $ Imp.DebugPrint "\n# SegHist" Nothing+ emit $ Imp.DebugPrint "Memory per set of subhistograms per segment" $ Just h+ emit $ Imp.DebugPrint "Memory per set of subhistograms times segments" $ Just seg_h+ emit $ Imp.DebugPrint "Input elements per histogram (N)" $ Just hist_N+ emit $ Imp.DebugPrint "Desired group size (B)" $ Just hist_B+ emit $ Imp.DebugPrint "Histogram size (H)" $ Just hist_H+ emit $ Imp.DebugPrint "Histogram element size (el_size)" $ Just hist_el_size+ emit $ Imp.DebugPrint "Race factor (RF)" $ Just hist_RF++ (use_local_memory, run_in_local_memory) <-+ localMemoryCase map_pes num_groups group_size space hist_H hist_el_size hist_N hist_RF slugs kbody++ sIf use_local_memory run_in_local_memory $+ histKernelGlobal map_pes num_groups group_size space slugs kbody++ let pes_per_op = chunks (map (length . histDest) ops) all_red_pes++ forM_ (zip3 slugs pes_per_op ops) $ \(slug, red_pes, op) -> do+ let num_histos = slugNumSubhistos slug+ subhistos = map subhistosArray $ slugSubhistos slug++ let unitHistoCase =+ -- This is OK because the memory blocks are at least as+ -- large as the ones we are supposed to use for the result.+ forM_ (zip red_pes subhistos) $ \(pe, subhisto) -> do+ pe_mem <- memLocationName . entryArrayLocation <$>+ lookupArray (patElemName pe)+ subhisto_mem <- memLocationName . entryArrayLocation <$>+ lookupArray subhisto+ emit $ Imp.SetMem pe_mem subhisto_mem $ Space "device"++ sIf (Imp.var num_histos int32 .==. 1) unitHistoCase $ do+ -- For the segmented reduction, we keep the segment dimensions+ -- unchanged. To this, we add two dimensions: one over the number+ -- of buckets, and one over the number of subhistograms. This+ -- inner dimension is the one that is collapsed in the reduction.+ let num_buckets = histWidth op++ bucket_id <- newVName "bucket_id"+ subhistogram_id <- newVName "subhistogram_id"+ vector_ids <- mapM (const $ newVName "vector_id") $+ shapeDims $ histShape op++ flat_gtid <- newVName "flat_gtid"++ let lvl = SegThread num_groups group_size SegVirt+ segred_space =+ SegSpace flat_gtid $+ segment_dims +++ [(bucket_id, num_buckets)] +++ zip vector_ids (shapeDims $ histShape op) +++ [(subhistogram_id, Var num_histos)]++ let segred_op = SegRedOp Commutative (histOp op) (histNeutral op) mempty+ compileSegRed' (Pattern [] red_pes) lvl segred_space [segred_op] $ \_ red_cont ->+ red_cont $ flip map subhistos $ \subhisto ->+ (Var subhisto, map Imp.vi32 $+ map fst segment_dims ++ [subhistogram_id, bucket_id] ++ vector_ids)++ where segment_dims = init $ unSegSpace space
src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs view
@@ -55,7 +55,6 @@ import Prelude hiding (quot, rem) import Futhark.Error-import Futhark.MonadFreshNames import Futhark.Transform.Rename import Futhark.Representation.ExplicitMemory import qualified Futhark.CodeGen.ImpCode.Kernels as Imp@@ -231,10 +230,10 @@ required_groups = num_segments `quotRoundingUp` segments_per_group emit $ Imp.DebugPrint "\n# SegRed-small" Nothing- emit $ Imp.DebugPrint "num_segments" $ Just (int32, num_segments)- emit $ Imp.DebugPrint "segment_size" $ Just (int32, segment_size)- emit $ Imp.DebugPrint "segments_per_group" $ Just (int32, segments_per_group)- emit $ Imp.DebugPrint "required_groups" $ Just (int32, required_groups)+ emit $ Imp.DebugPrint "num_segments" $ Just num_segments+ emit $ Imp.DebugPrint "segment_size" $ Just segment_size+ emit $ Imp.DebugPrint "segments_per_group" $ Just segments_per_group+ emit $ Imp.DebugPrint "required_groups" $ Just required_groups sKernelThread "segred_small" num_groups' group_size' (segFlat space) $ \constants -> do @@ -323,13 +322,13 @@ groups_per_segment * unCount group_size' emit $ Imp.DebugPrint "\n# SegRed-large" Nothing- emit $ Imp.DebugPrint "num_segments" $ Just (int32, num_segments)- emit $ Imp.DebugPrint "segment_size" $ Just (int32, segment_size)- emit $ Imp.DebugPrint "virt_num_groups" $ Just (int32, Imp.vi32 virt_num_groups)- emit $ Imp.DebugPrint "num_groups" $ Just (int32, Imp.unCount num_groups')- emit $ Imp.DebugPrint "group_size" $ Just (int32, Imp.unCount group_size')- emit $ Imp.DebugPrint "elems_per_thread" $ Just (int32, Imp.unCount elems_per_thread)- emit $ Imp.DebugPrint "groups_per_segment" $ Just (int32, groups_per_segment)+ emit $ Imp.DebugPrint "num_segments" $ Just num_segments+ emit $ Imp.DebugPrint "segment_size" $ Just segment_size+ emit $ Imp.DebugPrint "virt_num_groups" $ Just $ Imp.vi32 virt_num_groups+ emit $ Imp.DebugPrint "num_groups" $ Just $ Imp.unCount num_groups'+ emit $ Imp.DebugPrint "group_size" $ Just $ Imp.unCount group_size'+ emit $ Imp.DebugPrint "elems_per_thread" $ Just $ Imp.unCount elems_per_thread+ emit $ Imp.DebugPrint "groups_per_segment" $ Just groups_per_segment reds_group_res_arrs <- groupResultArrays (Count (Var virt_num_groups)) group_size reds @@ -510,7 +509,6 @@ forM_ (zip (slugAccs slug) (lambdaParams slug_op_renamed)) $ \((acc, acc_is), p) -> copyDWIM acc (acc_is++vec_is) (Var $ paramName p) [] - i <- newVName "i" -- If this is a non-commutative reduction, each thread must run the -- loop the same number of iterations, because we will be performing -- a group-wide reduction in there.@@ -521,16 +519,16 @@ Noncommutative -> (Imp.unCount elems_per_thread, sWhen (Imp.var gtid int32 .<. Imp.unCount num_elements)) - sFor i Int32 bound $ do+ sFor "i" bound $ \i -> do gtid <-- case comm of Commutative -> global_tid +- Imp.var threads_per_segment int32 * Imp.var i int32+ Imp.var threads_per_segment int32 * i Noncommutative -> let index_in_segment = global_tid `quot` kernelGroupSize constants in local_tid +- (index_in_segment * Imp.unCount elems_per_thread + Imp.var i int32) *+ (index_in_segment * Imp.unCount elems_per_thread + i) * kernelGroupSize constants check_bounds $ sComment "apply map function" $
src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs view
@@ -10,7 +10,6 @@ import Prelude hiding (quot, rem) -import Futhark.MonadFreshNames import Futhark.Transform.Rename import Futhark.Representation.ExplicitMemory import qualified Futhark.CodeGen.ImpCode.Kernels as Imp@@ -78,10 +77,9 @@ forM_ (zip scan_x_params nes) $ \(p, ne) -> copyDWIM (paramName p) [] ne [] - j <- newVName "j"- sFor j Int32 elems_per_thread $ do+ sFor "j" elems_per_thread $ \j -> do chunk_offset <- dPrimV "chunk_offset" $- kernelGroupSize constants * Imp.var j int32 ++ kernelGroupSize constants * j + kernelGroupId constants * elems_per_group flat_idx <- dPrimV "flat_idx" $ Imp.var chunk_offset int32 + kernelLocalThreadId constants@@ -247,7 +245,7 @@ scanStage1 pat (segNumGroups lvl) (segGroupSize lvl) space scan_op nes kbody emit $ Imp.DebugPrint "\n# SegScan" Nothing- emit $ Imp.DebugPrint "elems_per_group" $ Just (int32, elems_per_group)+ emit $ Imp.DebugPrint "elems_per_group" $ Just elems_per_group scan_op' <- renameLambda scan_op scan_op'' <- renameLambda scan_op
src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs view
@@ -30,7 +30,6 @@ import Futhark.MonadFreshNames import Futhark.Representation.ExplicitMemory (allScalarMemory) import Futhark.Util (zEncodeString)-import Futhark.Util.Pretty (pretty) kernelsToCUDA, kernelsToOpenCL :: ImpKernels.Program -> Either InternalError ImpOpenCL.Program@@ -49,11 +48,21 @@ opencl_code = openClCode $ M.elems kernels opencl_prelude = pretty $ genPrelude target requirements return $ ImpOpenCL.Program opencl_code opencl_prelude kernel_names- (S.toList $ openclUsedTypes requirements) sizes $+ (S.toList $ openclUsedTypes requirements) (cleanSizes sizes) $ ImpOpenCL.Functions (M.toList extra_funs) <> prog' where genPrelude TargetOpenCL = genOpenClPrelude genPrelude TargetCUDA = genCUDAPrelude +-- | Due to simplifications after kernel extraction, some threshold+-- parameters may contain KernelPaths that reference threshold+-- parameters that no longer exist. We remove these here.+cleanSizes :: M.Map Name SizeClass -> M.Map Name SizeClass+cleanSizes m = M.map clean m+ where known = M.keys m+ clean (SizeThreshold path) =+ SizeThreshold $ filter ((`elem` known) . fst) path+ clean s = s+ pointerQuals :: Monad m => String -> m [C.TypeQual] pointerQuals "global" = return [C.ctyquals|__global|] pointerQuals "local" = return [C.ctyquals|__local|]@@ -62,8 +71,11 @@ pointerQuals "write_only" = return [C.ctyquals|__write_only|] pointerQuals "read_only" = return [C.ctyquals|__read_only|] pointerQuals "kernel" = return [C.ctyquals|__kernel|]-pointerQuals s = fail $ "'" ++ s ++ "' is not an OpenCL kernel address space."+pointerQuals s = error $ "'" ++ s ++ "' is not an OpenCL kernel address space." +-- In-kernel name and per-workgroup size in bytes.+type LocalMemoryUse = (VName, Count Bytes Exp)+ newtype KernelRequirements = KernelRequirements { kernelLocalMemory :: [LocalMemoryUse] } @@ -166,25 +178,16 @@ num_groups = kernelNumGroups kernel group_size = kernelGroupSize kernel - prepareLocalMemory TargetOpenCL (mem, Left size) = do+ prepareLocalMemory TargetOpenCL (mem, size) = do mem_aligned <- newVName $ baseString mem ++ "_aligned" return (Just $ SharedMemoryKArg size, Just [C.cparam|__local volatile typename int64_t* $id:mem_aligned|], [C.citem|__local volatile char* restrict $id:mem = (__local volatile char*)$id:mem_aligned;|])- prepareLocalMemory TargetOpenCL (mem, Right size) = do- let size' = compilePrimExp size- return (Nothing, Nothing,- [C.citem|ALIGNED_LOCAL_MEMORY($id:mem, $exp:size');|])- prepareLocalMemory TargetCUDA (mem, Left size) = do+ prepareLocalMemory TargetCUDA (mem, size) = do param <- newVName $ baseString mem ++ "_offset" return (Just $ SharedMemoryKArg size, Just [C.cparam|uint $id:param|], [C.citem|volatile char *$id:mem = &shared_mem[$id:param];|])- prepareLocalMemory TargetCUDA (mem, Right size) = do- -- We declare the shared memory array as int64_t to force alignment.- let size' = compilePrimExp size- return (Nothing, Nothing,- [CUDAC.citem|__shared__ volatile typename int64_t $id:mem[(($exp:size' + 7) & ~7)/8];|]) useAsParam :: KernelUse -> Maybe C.Param useAsParam (ScalarUse name bt) =@@ -239,9 +242,6 @@ typedef uint uint32_t; typedef ulong uint64_t; -// We declare the shared memory array as int64_t to force alignment.-$esc:("#define ALIGNED_LOCAL_MEMORY(m,size) __local int64_t m[((size + 7) & ~7)/8]")- // NVIDIAs OpenCL does not create device-wide memory fences (see #734), so we // use inline assembly if we detect we are on an NVIDIA GPU. $esc:("#ifdef cl_nv_pragma_unroll")@@ -500,19 +500,19 @@ cannotAllocate :: GenericC.Allocate KernelOp KernelRequirements cannotAllocate _ =- fail "Cannot allocate memory in kernel"+ error "Cannot allocate memory in kernel" cannotDeallocate :: GenericC.Deallocate KernelOp KernelRequirements cannotDeallocate _ _ =- fail "Cannot deallocate memory in kernel"+ error "Cannot deallocate memory in kernel" copyInKernel :: GenericC.Copy KernelOp KernelRequirements copyInKernel _ _ _ _ _ _ _ =- fail "Cannot bulk copy in kernel."+ error "Cannot bulk copy in kernel." noStaticArrays :: GenericC.StaticArray KernelOp KernelRequirements noStaticArrays _ _ _ _ =- fail "Cannot create static array in kernel."+ error "Cannot create static array in kernel." kernelMemoryType space | Just t <- M.lookup space allScalarMemory =@@ -566,7 +566,7 @@ typesInExp e <> typesInCode c1 <> typesInCode c2 typesInCode (Assert e _ _) = typesInExp e typesInCode (Comment _ c) = typesInCode c-typesInCode (DebugPrint _ v) = maybe mempty (typesInExp . snd) v+typesInCode (DebugPrint _ v) = maybe mempty typesInExp v typesInCode Op{} = mempty typesInExp :: Exp -> S.Set PrimType
src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs view
@@ -215,7 +215,7 @@ mapTransposeKernel desc block_dim_int args t kind = Kernel { kernelBody = DeclareMem block (Space "local") <>- Op (LocalAlloc block (Right block_size)) <>+ Op (LocalAlloc block block_size) <> mapTranspose block_dim args t kind , kernelUses = uses , kernelNumGroups = num_groups
src/Futhark/CodeGen/SetDefaultSpace.hs view
@@ -82,7 +82,7 @@ setBodySpace space (Assert e msg loc) = Assert (setExpSpace space e) msg loc setBodySpace space (DebugPrint s v) =- DebugPrint s $ fmap (fmap (setExpSpace space)) v+ DebugPrint s $ fmap (setExpSpace space) v setBodySpace _ (Op op) = Op op
src/Futhark/Internalise.hs view
@@ -734,14 +734,14 @@ -- Builtin operators are handled specially because they are -- overloaded.-internaliseExp desc (E.BinOp op _ (xe,_) (ye,_) _ loc)+internaliseExp desc (E.BinOp (op, _) _ (xe,_) (ye,_) _ loc) | Just internalise <- isOverloadedFunction op [xe, ye] loc = internalise desc -- User-defined operators are just the same as a function call.-internaliseExp desc (E.BinOp op (Info t) (xarg, Info xt) (yarg, Info yt) _ loc) =+internaliseExp desc (E.BinOp (op, oploc) (Info t) (xarg, Info xt) (yarg, Info yt) _ loc) = internaliseExp desc $- E.Apply (E.Apply (E.Var op (Info t) loc) xarg (Info $ E.diet xt)+ E.Apply (E.Apply (E.Var op (Info t) oploc) xarg (Info $ E.diet xt) (Info $ foldFunType [E.fromStruct yt] t) loc) yarg (Info $ E.diet yt) (Info t) loc @@ -972,22 +972,23 @@ w <- arraysSize 0 <$> mapM lookupType arrs letTupExp' desc . I.Op =<< f w lam' nes' arrs -internaliseGenReduce :: String- -> E.Exp -> E.Exp -> E.Exp -> E.Exp -> E.Exp -> SrcLoc- -> InternaliseM [SubExp]-internaliseGenReduce desc hist op ne buckets img loc = do- ne' <- internaliseExp "gen_reduce_ne" ne- hist' <- internaliseExpToVars "gen_reduce_hist" hist- buckets' <- letExp "gen_reduce_buckets" . BasicOp . SubExp =<<- internaliseExp1 "gen_reduce_buckets" buckets- img' <- internaliseExpToVars "gen_reduce_img" img+internaliseHist :: String+ -> E.Exp -> E.Exp -> E.Exp -> E.Exp -> E.Exp -> E.Exp -> SrcLoc+ -> InternaliseM [SubExp]+internaliseHist desc rf hist op ne buckets img loc = do+ rf' <- internaliseExp1 "hist_rf" rf+ ne' <- internaliseExp "hist_ne" ne+ hist' <- internaliseExpToVars "hist_hist" hist+ buckets' <- letExp "hist_buckets" . BasicOp . SubExp =<<+ internaliseExp1 "hist_buckets" buckets+ img' <- internaliseExpToVars "hist_img" img -- reshape neutral element to have same size as the destination array ne_shp <- forM (zip ne' hist') $ \(n, h) -> do rowtype <- I.stripArray 1 <$> lookupType h ensureShape asserting "Row shape of destination array does not match shape of neutral element"- loc rowtype "gen_reduce_ne_right_shape" n+ loc rowtype "hist_ne_right_shape" n ne_ts <- mapM I.subExpType ne_shp his_ts <- mapM lookupType hist' op' <- internaliseFoldLambda internaliseLambda op ne_ts his_ts@@ -1001,7 +1002,7 @@ body = mkBody mempty $ map (I.Var . paramName) params body' <- localScope (scopeOfLParams params) $ ensureResultShape asserting- "Row shape of value array does not match row shape of gen_reduce target"+ "Row shape of value array does not match row shape of hist target" (srclocOf img) rettype body -- get sizes of histogram and image arrays@@ -1020,7 +1021,7 @@ I.BasicOp $ I.Reshape (reshapeOuter [DimCoercion w_img] 1 b_shape) buckets' letTupExp' desc $ I.Op $- I.GenReduce w_img [GenReduceOp w_hist hist' ne_shp op'] (I.Lambda params body' rettype) $ buckets'' : img'+ I.Hist w_img [HistOp w_hist rf' hist' ne_shp op'] (I.Lambda params body' rettype) $ buckets'' : img' internaliseStreamMap :: String -> StreamOrd -> E.Exp -> E.Exp -> InternaliseM [SubExp]@@ -1157,6 +1158,8 @@ simpleBinOp desc (I.SMod t) x y internaliseBinOp desc E.Mod x y (E.Unsigned t) _ = simpleBinOp desc (I.UMod t) x y+internaliseBinOp desc E.Mod x y (E.FloatType t) _ =+ simpleBinOp desc (I.FMod t) x y internaliseBinOp desc E.Quot x y (E.Signed t) _ = simpleBinOp desc (I.SQuot t) x y internaliseBinOp desc E.Quot x y (E.Unsigned t) _ =@@ -1302,7 +1305,7 @@ x' <- internaliseExp1 "x" x fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp unop x' - handle [x,y] s+ handle [TupLit [x,y] _] s | Just bop <- find ((==s) . pretty) allBinOps = Just $ \desc -> do x' <- internaliseExp1 "x" x y' <- internaliseExp1 "y" y@@ -1502,8 +1505,8 @@ handle [TupLit [f, arr] _] "map_stream_per" = Just $ \desc -> internaliseStreamMap desc Disorder f arr - handle [TupLit [dest, op, ne, buckets, img] _] "gen_reduce" = Just $ \desc ->- internaliseGenReduce desc dest op ne buckets img loc+ handle [TupLit [rf, dest, op, ne, buckets, img] _] "hist" = Just $ \desc ->+ internaliseHist desc rf dest op ne buckets img loc handle [x] "unzip" = Just $ flip internaliseExp x handle [x] "trace" = Just $ flip internaliseExp x
src/Futhark/Internalise/Bindings.hs view
@@ -16,12 +16,10 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Loc-import Data.Traversable (mapM) import Language.Futhark as E import qualified Futhark.Representation.SOACS as I import Futhark.MonadFreshNames- import Futhark.Internalise.Monad import Futhark.Internalise.TypesValues import Futhark.Internalise.AccurateSizes
src/Futhark/Internalise/Defunctionalise.hs view
@@ -3,9 +3,9 @@ module Futhark.Internalise.Defunctionalise ( transformProg ) where -import Control.Arrow (first, second)+import qualified Control.Arrow as Arrow import Control.Monad.RWS hiding (Sum)-import Data.Bifunctor hiding (first, second)+import Data.Bifunctor import Data.Foldable import Data.List import qualified Data.List.NonEmpty as NE@@ -42,7 +42,7 @@ type Env = M.Map VName StaticVal localEnv :: Env -> DefM a -> DefM a-localEnv env = local $ second (env<>)+localEnv env = local $ Arrow.second (env<>) -- Even when using a "new" environment (for evaluating closures) we -- still ram the global environment of DynamicFuns in there.@@ -57,7 +57,7 @@ askEnv = asks snd isGlobal :: VName -> DefM a -> DefM a-isGlobal v = local $ first (S.insert v)+isGlobal v = local $ Arrow.first (S.insert v) -- | Returns the defunctionalization environment restricted -- to the given set of variable names and types.@@ -292,8 +292,8 @@ M.singleton vn $ Dynamic tp -- We handle BinOps by turning them into ordinary function applications.-defuncExp (BinOp qn (Info t) (e1, Info pt1) (e2, Info pt2) (Info ret) loc) =- defuncExp $ Apply (Apply (Var qn (Info t) loc)+defuncExp (BinOp (qn, qnloc) (Info t) (e1, Info pt1) (e2, Info pt2) (Info ret) loc) =+ defuncExp $ Apply (Apply (Var qn (Info t) qnloc) e1 (Info (diet pt1)) (Info (Scalar $ Arrow mempty Unnamed (fromStruct pt2) ret)) loc) e2 (Info (diet pt2)) (Info ret) loc @@ -831,8 +831,8 @@ formVars (ForIn p e2) = (freeVars e2, patternVars p) formVars (While e2) = (freeVars e2, mempty) - BinOp qn _ (e1, _) (e2, _) _ _ -> oneName (qualLeaf qn) <>- freeVars e1 <> freeVars e2+ BinOp (qn, _) _ (e1, _) (e2, _) _ _ -> oneName (qualLeaf qn) <>+ freeVars e1 <> freeVars e2 Project _ e _ _ -> freeVars e LetWith id1 id2 idxs e1 e2 _ _ ->@@ -875,7 +875,7 @@ defuncValBind $ ValBind entry name Nothing (Info $ onlyConstantDims rettype') tparams (params <> body_pats) body' Nothing loc- where onlyConstantDims = bimap onDim id+ where onlyConstantDims = first onDim onDim (ConstDim x) = ConstDim x onDim _ = AnyDim
src/Futhark/Internalise/Defunctorise.hs view
@@ -113,7 +113,7 @@ lookupImport :: String -> TransformM Scope lookupImport name = maybe bad return =<< asks (M.lookup name . envImports)- where bad = fail $ "Unknown import: " ++ name+ where bad = error $ "Unknown import: " ++ name lookupMod' :: QualName VName -> Scope -> Either String Mod lookupMod' mname scope =@@ -122,7 +122,7 @@ where bad mname' = "Unknown module: " ++ pretty mname ++ " (" ++ pretty mname' ++ ")" lookupMod :: QualName VName -> TransformM Mod-lookupMod mname = either fail return . lookupMod' mname =<< askScope+lookupMod mname = either error return . lookupMod' mname =<< askScope runTransformM :: VNameSource -> TransformM a -> (a, VNameSource, DL.DList Dec) runTransformM src (TransformM m) = runRWS m env src@@ -167,7 +167,7 @@ arg_mod <- evalModExp arg case f_mod of ModMod _ ->- fail $ "Cannot apply non-parametric module at " ++ locStr loc+ error $ "Cannot apply non-parametric module at " ++ locStr loc ModFun f_abs f_closure f_p f_body -> bindingAbs (f_abs <> S.fromList (unInfo (modParamAbs f_p))) $ extendAbsTypes b_substs $ extendScope f_closure $ generating $ do@@ -215,7 +215,7 @@ case e of QualParens mn e' _ -> case lookupMod' mn scope of- Left err -> fail err+ Left err -> error err Right mod -> astMap (substituter $ modScope mod<>scope) e' _ -> astMap (substituter scope) e
src/Futhark/Internalise/Monomorphise.hs view
@@ -155,7 +155,7 @@ -- As an attempt at an optimisation, only transform the aliases if -- they refer to a variable we have record-replaced. return $ if any ((`M.member` rrs) . aliasVar) $ aliases t- then bimap id (mconcat . map replace . S.toList) t+ then second (mconcat . map replace . S.toList) t else t -- | Monomorphization of expressions.@@ -282,11 +282,11 @@ e3' <- transformExp e3 return $ DoLoop pat e1' form' e3' loc -transformExp (BinOp (QualName qs fname) (Info t) (e1, d1) (e2, d2) tp loc) = do+transformExp (BinOp (QualName qs fname, oploc) (Info t) (e1, d1) (e2, d2) tp loc) = do fname' <- transformFName fname (toStructural t) e1' <- transformExp e1 e2' <- transformExp e2- return $ BinOp (QualName qs fname') (Info t) (e1', d1) (e2', d2) tp loc+ return $ BinOp (QualName qs fname', oploc) (Info t) (e1', d1) (e2', d2) tp loc transformExp (Project n e tp loc) = do maybe_fs <- case e of@@ -346,7 +346,7 @@ desugarBinOpSection qn e_left e_right t xtype ytype rettype loc = do (e1, p1) <- makeVarParam e_left $ fromStruct xtype (e2, p2) <- makeVarParam e_right $ fromStruct ytype- let body = BinOp qn (Info t) (e1, Info xtype) (e2, Info ytype) (Info rettype) loc+ let body = BinOp (qn, loc) (Info t) (e1, Info xtype) (e2, Info ytype) (Info rettype) loc rettype' = toStruct rettype return $ Lambda (p1 ++ p2) body Nothing (Info (mempty, rettype')) loc
src/Futhark/Internalise/TypesValues.hs view
@@ -24,7 +24,6 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe-import Data.Monoid ((<>)) import qualified Language.Futhark as E import Futhark.Representation.SOACS as I@@ -118,9 +117,9 @@ E.Scalar (E.Record ets) -> concat <$> mapM (internaliseTypeM . snd) (E.sortFields ets) E.Scalar E.TypeVar{} ->- fail "internaliseTypeM: cannot handle type variable."+ error "internaliseTypeM: cannot handle type variable." E.Scalar E.Arrow{} ->- fail $ "internaliseTypeM: cannot handle function type: " ++ pretty orig_t+ error $ "internaliseTypeM: cannot handle function type: " ++ pretty orig_t E.Scalar (E.Sum cs) -> do (ts, _) <- internaliseConstructors <$> traverse (fmap concat . mapM internaliseTypeM) cs
src/Futhark/Optimise/Fusion.hs view
@@ -617,10 +617,10 @@ fres' <- addNamesToInfusible fres $ namesFromList $ patternNames pat mapLike fres' soac lam - Right soac@(SOAC.GenReduce _ _ lam _) -> do- -- We put the variables produced by GenReduce into the infusible+ Right soac@(SOAC.Hist _ _ lam _) -> do+ -- We put the variables produced by Hist into the infusible -- set to force horizontal fusion. It is not possible to- -- producer/consumer-fuse GenReduce anyway.+ -- producer/consumer-fuse Hist anyway. fres' <- addNamesToInfusible fres $ namesFromList $ patternNames pat mapLike fres' soac lam @@ -833,9 +833,9 @@ SOAC.Scatter w lam inps dests -> do lam' <- simplifyAndFuseInLambda lam return $ SOAC.Scatter w lam' inps dests- SOAC.GenReduce w ops lam arrs -> do+ SOAC.Hist w ops lam arrs -> do lam' <- simplifyAndFuseInLambda lam- return $ SOAC.GenReduce w ops lam' arrs+ return $ SOAC.Hist w ops lam' arrs SOAC.Stream w form lam inps -> do lam' <- simplifyAndFuseInLambda lam return $ SOAC.Stream w form lam' inps
src/Futhark/Optimise/Fusion/LoopKernel.hs view
@@ -292,7 +292,7 @@ -- Scatter fusion -- ------------------ - -- Map-write fusion.+ -- Map-Scatter fusion. -- -- The 'inplace' mechanism for kernels already takes care of -- checking that the Scatter is not writing to any array used in@@ -309,26 +309,26 @@ success (outNames ker ++ extra_nms) $ SOAC.Scatter w res_lam' new_inp dests - -- Map-genreduce fusion.+ -- Map-Hist fusion. -- -- The 'inplace' mechanism for kernels already takes care of- -- checking that the GenReduce is not writing to any array used in+ -- checking that the Hist is not writing to any array used in -- the Map.- (SOAC.GenReduce _ ops _ _,+ (SOAC.Hist _ ops _ _, SOAC.Screma _ form _) | isJust $ isMapSOAC form, -- 1. all arrays produced by the map are ONLY used (consumed)- -- by the genreduce, i.e., not used elsewhere.+ -- by the hist, i.e., not used elsewhere. not (any (`nameIn` unfus_set) outVars), -- 2. all arrays produced by the map are input to the scatter. mapWriteFusionOK outVars ker -> do let (extra_nms, res_lam', new_inp) = mapLikeFusionCheck success (outNames ker ++ extra_nms) $- SOAC.GenReduce w ops res_lam' new_inp+ SOAC.Hist w ops res_lam' new_inp - -- Genreduce-Genreduce fusion- (SOAC.GenReduce _ ops_c _ _,- SOAC.GenReduce _ ops_p _ _)+ -- Hist-Hist fusion+ (SOAC.Hist _ ops_c _ _,+ SOAC.Hist _ ops_p _ _) | horizFuse -> do let p_num_buckets = length ops_p c_num_buckets = length ops_c@@ -349,7 +349,7 @@ drop p_num_buckets (lambdaReturnType lam_p) } success (outNames ker ++ returned_outvars) $- SOAC.GenReduce w (ops_c <> ops_p) lam' (inp_c_arr <> inp_p_arr)+ SOAC.Hist w (ops_c <> ops_p) lam' (inp_c_arr <> inp_p_arr) -- Scatter-write fusion. (SOAC.Scatter _len2 _lam_c ivs2 as2,@@ -714,24 +714,6 @@ return (op' inputs', ots') pullReshape _ _ = fail "Cannot pull reshape" --- We can make a Replicate output-transform part of a map SOAC simply--- by adding another dimension to the SOAC.-pullReplicate :: SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms)-pullReplicate soac@(SOAC.Screma _ form _) ots- | Just _ <- isMapSOAC form,- SOAC.Replicate cs (Shape [n]) SOAC.:< ots' <- SOAC.viewf ots = do- let rettype = SOAC.typeOf soac- body <- runBodyBinder $ do- names <- certifying cs $- letTupExp "pull_replicate" =<< SOAC.toExp soac- resultBodyM $ map Var names- let lam = Lambda { lambdaReturnType = rettype- , lambdaBody = body- , lambdaParams = []- }- return (SOAC.Screma n (Futhark.mapSOAC lam) [], ots')-pullReplicate _ _ = fail "Cannot pull replicate"- -- Tie it all together in exposeInputs (for making inputs to a -- consumer available) and pullOutputTransforms (for moving -- output-transforms of a producer to its inputs instead).@@ -769,7 +751,7 @@ exposed inp = SOAC.inputArray inp `notElem` inpIds outputTransformPullers :: [SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms)]-outputTransformPullers = [pullRearrange, pullReshape, pullReplicate]+outputTransformPullers = [pullRearrange, pullReshape] pullOutputTransforms :: SOAC -> SOAC.ArrayTransforms -> TryFusion (SOAC, SOAC.ArrayTransforms)
src/Futhark/Optimise/InPlaceLowering.hs view
@@ -271,7 +271,7 @@ bindingNumber name = do res <- asks $ fmap entryNumber . M.lookup name . topDownTable case res of Just n -> return n- Nothing -> fail $ "bindingNumber: variable " +++ Nothing -> error $ "bindingNumber: variable " ++ pretty name ++ " not found." deepen :: ForwardingM lore a -> ForwardingM lore a@@ -288,14 +288,14 @@ current <- asks topDownDepth res <- asks $ fmap entryDepth . M.lookup name . topDownTable case res of Just d -> return $ d == current- Nothing -> fail $ "isInCurrentBody: variable " +++ Nothing -> error $ "isInCurrentBody: variable " ++ pretty name ++ " not found." isOptimisable :: VName -> ForwardingM lore Bool isOptimisable name = do res <- asks $ fmap entryOptimisable . M.lookup name . topDownTable case res of Just b -> return b- Nothing -> fail $ "isOptimisable: variable " +++ Nothing -> error $ "isOptimisable: variable " ++ pretty name ++ " not found." seenVar :: VName -> ForwardingM lore ()
src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs view
@@ -18,7 +18,6 @@ import Futhark.Representation.Kernels import Futhark.Construct import Futhark.Optimise.InPlaceLowering.SubstituteIndices-import Futhark.Tools (fullSlice) data DesiredUpdate attr = DesiredUpdate { updateName :: VName -- ^ Name of result.
src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs view
@@ -17,7 +17,6 @@ import Futhark.Representation.AST.Attributes.Aliases import Futhark.Representation.AST import Futhark.Construct-import Futhark.Tools (fullSlice) import Futhark.Util type IndexSubstitution attr = (Certificates, VName, attr, Slice SubExp)
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -105,6 +105,8 @@ , envVtable = mempty } +type Protect m = SubExp -> Pattern (Lore m) -> Op (Lore m) -> Maybe (m ())+ data SimpleOps lore = SimpleOps { mkExpAttrS :: ST.SymbolTable (Wise lore) -> Pattern (Wise lore) -> Exp (Wise lore)@@ -115,6 +117,10 @@ , mkLetNamesS :: ST.SymbolTable (Wise lore) -> [VName] -> Exp (Wise lore) -> SimpleM lore (Stm (Wise lore), Stms (Wise lore))+ , protectHoistedOpS :: Protect (Binder (Wise lore))+ -- ^ Make a hoisted Op safe. The SubExp is a boolean+ -- that is true when the value of the statement will+ -- actually be used. , simplifyOpS :: SimplifyOp lore (Op lore) } @@ -122,10 +128,11 @@ bindableSimpleOps :: (SimplifiableLore lore, Bindable lore) => SimplifyOp lore (Op lore) -> SimpleOps lore-bindableSimpleOps = SimpleOps mkExpAttrS' mkBodyS' mkLetNamesS'+bindableSimpleOps = SimpleOps mkExpAttrS' mkBodyS' mkLetNamesS' protectHoistedOpS' where mkExpAttrS' _ pat e = return $ mkExpAttr pat e mkBodyS' _ bnds res = return $ mkBody bnds res mkLetNamesS' _ name e = (,) <$> mkLetNames name e <*> pure mempty+ protectHoistedOpS' _ _ _ = Nothing newtype SimpleM lore a = SimpleM (ReaderT (SimpleOps lore, Env lore) (State (VNameSource, Bool, Certificates)) a)@@ -143,7 +150,7 @@ vtable <- askVtable case ST.lookupType name vtable of Just t -> return t- Nothing -> fail $+ Nothing -> error $ "SimpleM.lookupType: cannot find variable " ++ pretty name ++ " in symbol table." @@ -238,11 +245,12 @@ -> SimpleM lore (a, Stms (Wise lore)) protectIfHoisted cond side m = do (x, stms) <- m+ ops <- asks $ protectHoistedOpS . fst runBinder $ do if any (not . safeExp . stmExp) stms then do cond' <- if side then return cond else letSubExp "cond_neg" $ BasicOp $ UnOp Not cond- mapM_ (protectIf unsafeOrCostly cond') stms+ mapM_ (protectIf ops unsafeOrCostly cond') stms else addStms stms return x where unsafeOrCostly e = not (safeExp e) || not (cheapExp e)@@ -258,10 +266,11 @@ -> SimpleM lore (a, Stms (Wise lore)) protectLoopHoisted ctx val form m = do (x, stms) <- m+ ops <- asks $ protectHoistedOpS . fst runBinder $ do if any (not . safeExp . stmExp) stms then do is_nonempty <- checkIfNonEmpty- mapM_ (protectIf (not . safeExp) is_nonempty) stms+ mapM_ (protectIf ops (not . safeExp) is_nonempty) stms else addStms stms return x where checkIfNonEmpty =@@ -275,14 +284,24 @@ letSubExp "loop_nonempty" $ BasicOp $ CmpOp (CmpSlt it) (intConst it 0) bound -protectIf :: MonadBinder m => (Exp (Lore m) -> Bool) -> SubExp -> Stm (Lore m) -> m ()-protectIf _ taken (Let pat (StmAux cs _)- (If cond taken_body untaken_body (IfAttr if_ts IfFallback))) = do+protectIf :: MonadBinder m =>+ Protect m+ -> (Exp (Lore m) -> Bool)+ -> SubExp -> Stm (Lore m) -> m ()+protectIf _ _ taken (Let pat (StmAux cs _)+ (If cond taken_body untaken_body (IfAttr if_ts IfFallback))) = do cond' <- letSubExp "protect_cond_conj" $ BasicOp $ BinOp LogAnd taken cond certifying cs $ letBind_ pat $ If cond' taken_body untaken_body $ IfAttr if_ts IfFallback-protectIf f taken (Let pat (StmAux cs _) e)+protectIf _ _ taken (Let pat (StmAux cs _) (BasicOp (Assert cond msg loc))) = do+ not_taken <- letSubExp "loop_not_taken" $ BasicOp $ UnOp Not taken+ cond' <- letSubExp "protect_assert_disj" $ BasicOp $ BinOp LogOr not_taken cond+ certifying cs $ letBind_ pat $ BasicOp $ Assert cond' msg loc+protectIf protect _ taken (Let pat (StmAux cs _) (Op op))+ | Just m <- protect taken pat op =+ certifying cs m+protectIf _ f taken (Let pat (StmAux cs _) e) | f e = do taken_body <- eBody [pure e] untaken_body <- eBody $ map (emptyOfType $ patternContextNames pat)@@ -291,7 +310,7 @@ certifying cs $ letBind_ pat $ If taken taken_body untaken_body $ IfAttr if_ts IfFallback-protectIf _ _ stm =+protectIf _ _ _ stm = addStm stm emptyOfType :: MonadBinder m => [VName] -> Type -> m (Exp (Lore m))@@ -695,7 +714,8 @@ where hoist = Mapper { -- Bodies are handled explicitly because we need to -- provide their result diet.- mapOnBody = fail "Unhandled body in simplification engine."+ mapOnBody =+ error "Unhandled body in simplification engine." , mapOnSubExp = simplify -- Lambdas are handled explicitly because we need to -- bind their parameters.@@ -703,11 +723,11 @@ , mapOnRetType = simplify , mapOnBranchType = simplify , mapOnFParam =- fail "Unhandled FParam in simplification engine."+ error "Unhandled FParam in simplification engine." , mapOnLParam =- fail "Unhandled LParam in simplification engine."+ error "Unhandled LParam in simplification engine." , mapOnOp =- fail "Unhandled Op in simplification engine."+ error "Unhandled Op in simplification engine." } type SimplifiableLore lore = (Attributes lore,
src/Futhark/Optimise/Simplify/Lore.hs view
@@ -29,6 +29,7 @@ import Control.Monad.Identity import Control.Monad.Reader+import qualified Data.Kind import qualified Data.Map.Strict as M import Futhark.Representation.AST@@ -258,7 +259,7 @@ class (AliasedOp (OpWithWisdom op), RangedOp (OpWithWisdom op), IsOp (OpWithWisdom op)) => CanBeWise op where- type OpWithWisdom op :: *+ type OpWithWisdom op :: Data.Kind.Type removeOpWisdom :: OpWithWisdom op -> op instance CanBeWise () where
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -21,8 +21,7 @@ import Control.Monad import Data.Either-import Data.Foldable (all)-import Data.List hiding (all)+import Data.List import Data.Maybe import qualified Data.Map.Strict as M
src/Futhark/Optimise/TileLoops.hs view
@@ -61,8 +61,8 @@ (res', stms') <- runBinder $ mapM (tilingTileReturns tiling) =<< tiledBody mempty return (host_stms, (tilingLevel tiling,- tilingSpace tiling,- KernelBody () stms' res'))+ tilingSpace tiling,+ KernelBody () stms' res')) Nothing -> return (mempty, (lvl, initial_kspace, kbody)) | otherwise =@@ -90,9 +90,10 @@ flip (M.findWithDefault mempty) variance) arrs, not $ gtid `nameIn` branch_variant, (prestms', poststms') <-- preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms) =+ preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms),+ used <- freeIn stm_to_tile <> freeIn stms_res = - Just . injectPrelude initial_space variance prestms' (freeIn stm_to_tile) <$>+ Just . injectPrelude initial_space variance prestms' used <$> tileGeneric (tiling1d $ reverse top_space_rev) initial_lvl res_ts (stmPattern stm_to_tile) gtid kdim@@ -105,9 +106,10 @@ gtid_y : gtid_x : top_gtids_rev <- reverse gtids, kdim_y : kdim_x : top_kdims_rev <- reverse kdims, (prestms', poststms') <-- preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms) =+ preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms),+ used <- freeIn stm_to_tile <> freeIn stms_res = - Just . injectPrelude initial_space variance prestms' (freeIn stm_to_tile) <$>+ Just . injectPrelude initial_space variance prestms' used <$> tileGeneric (tiling2d $ reverse $ zip top_gtids_rev top_kdims_rev) initial_lvl res_ts (stmPattern stm_to_tile) (gtid_x, gtid_y) (kdim_x, kdim_y)@@ -116,7 +118,7 @@ -- Tiling inside for-loop. | DoLoop [] merge (ForLoop i it bound []) loopbody <- stmExp stm_to_tile, (prestms', poststms') <-- preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms)= do+ preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms) = do let branch_variant' = branch_variant <>@@ -859,7 +861,7 @@ gid_y <- newVName "gid_y" tile_size_key <- nameFromString . pretty <$> newVName "tile_size"- tile_size <- letSubExp "tile_size" $ Op $ GetSize tile_size_key SizeTile+ tile_size <- letSubExp "tile_size" $ Op $ SizeOp $ GetSize tile_size_key SizeTile group_size <- letSubExp "group_size" $ BasicOp $ BinOp (Mul Int32) tile_size tile_size num_groups_x <- letSubExp "num_groups_x" =<<
src/Futhark/Pass/ExpandAllocations.hs view
@@ -90,13 +90,13 @@ return (alloc_stms, Op $ Inner $ SegOp $ SegScan lvl space (head scan_op') nes ts kbody') -transformExp (Op (Inner (SegOp (SegGenRed lvl space ops ts kbody)))) = do+transformExp (Op (Inner (SegOp (SegHist lvl space ops ts kbody)))) = do (alloc_stms, (lams', kbody')) <- transformScanRed lvl space lams kbody let ops' = zipWith onOp ops lams' return (alloc_stms,- Op $ Inner $ SegOp $ SegGenRed lvl space ops' ts kbody')- where lams = map genReduceOp ops- onOp op lam = op { genReduceOp = lam }+ Op $ Inner $ SegOp $ SegHist lvl space ops' ts kbody')+ where lams = map histOp ops+ onOp op lam = op { histOp = lam } transformExp e = return (mempty, e)@@ -489,14 +489,8 @@ unAllocOp Alloc{} = Left "unAllocOp: unhandled Alloc" unAllocOp (Inner OtherOp{}) = Left "unAllocOp: unhandled OtherOp"- unAllocOp (Inner (SplitSpace o w i elems_per_thread)) =- return $ SplitSpace o w i elems_per_thread- unAllocOp (Inner (GetSize name sclass)) =- return $ GetSize name sclass- unAllocOp (Inner (GetSizeMax sclass)) =- return $ GetSizeMax sclass- unAllocOp (Inner (CmpSizeLe name sclass x)) =- return $ CmpSizeLe name sclass x+ unAllocOp (Inner (SizeOp op)) =+ return $ SizeOp op unAllocOp (Inner (SegOp op)) = SegOp <$> mapSegOpM mapper op where mapper = identitySegOpMapper { mapOnSegOpLambda = unAllocLambda , mapOnSegOpBody = unAllocKernelBody@@ -541,6 +535,7 @@ kstms' <- either compilerLimitationS return $ unAllocKernelsStms kstms let num_sizes = length sizes i64s = replicate num_sizes $ Prim int64+ kernels_scope <- asks unAllocScope (max_lam, _) <- flip runBinderT kernels_scope $ do@@ -580,13 +575,17 @@ pat <- basicPattern [] <$> replicateM num_sizes (newIdent "max_per_thread" $ Prim int64) + w <- letSubExp "size_slice_w" =<<+ foldBinOp (Mul Int32) (intConst Int32 1) (segSpaceDims space)+ thread_space_iota <- letExp "thread_space_iota" $ BasicOp $- Iota num_threads (intConst Int32 0) (intConst Int32 1) Int32+ Iota w (intConst Int32 0) (intConst Int32 1) Int32 let red_op = SegRedOp Commutative max_lam (replicate num_sizes $ intConst Int64 0) mempty lvl <- segThread "segred"+ addStms =<< mapM renameStm =<<- nonSegRed lvl pat num_threads [red_op] size_lam' [thread_space_iota]+ nonSegRed lvl pat w [red_op] size_lam' [thread_space_iota] size_sums <- forM (patternNames pat) $ \threads_max -> letExp "size_sum" $
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -244,7 +244,7 @@ (Let pat _ _, extrabnds) <- allocsForStm sizes vals e case extrabnds of [] -> return pat- _ -> fail $ "Cannot make allocations for pattern of " ++ pretty e+ _ -> error $ "Cannot make allocations for pattern of " ++ pretty e allocsForPattern :: Allocator lore m => [Ident] -> [Ident] -> [ExpReturns] -> [ExpHint]@@ -293,7 +293,7 @@ instantiateIxFun :: Monad m => ExtIxFun -> m IxFun instantiateIxFun = traverse $ traverse inst- where inst Ext{} = fail "instantiateIxFun: not yet"+ where inst Ext{} = error "instantiateIxFun: not yet" inst (Free x) = return x summaryForBindage :: Allocator lore m =>@@ -485,7 +485,7 @@ memoryInRetType :: [RetType Kernels] -> [RetType ExplicitMemory] memoryInRetType ts = evalState (mapM addAttr ts) $ startOfFreeIDRange ts where addAttr (Prim t) = return $ MemPrim t- addAttr Mem{} = fail "memoryInRetType: too much memory"+ addAttr Mem{} = error "memoryInRetType: too much memory" addAttr (Array bt shape u) = do i <- get <* modify (+1) return $ MemArray bt shape u $ ReturnsNewBlock DefaultSpace i $@@ -507,17 +507,10 @@ handleHostOp :: HostOp Kernels (SOAC Kernels) -> AllocM Kernels ExplicitMemory (MemOp (HostOp ExplicitMemory ()))-handleHostOp (SplitSpace o w i elems_per_thread) =- return $ Inner $ SplitSpace o w i elems_per_thread-handleHostOp (GetSize key size_class) =- return $ Inner $ GetSize key size_class-handleHostOp (GetSizeMax size_class) =- return $ Inner $ GetSizeMax size_class-handleHostOp (CmpSizeLe key size_class x) =- return $ Inner $ CmpSizeLe key size_class x+handleHostOp (SizeOp op) =+ return $ Inner $ SizeOp op handleHostOp (OtherOp op) = fail $ "Cannot allocate memory in SOAC: " ++ pretty op- handleHostOp (SegOp op) = Inner . SegOp <$> handleSegOp op @@ -639,11 +632,11 @@ return $ If cond tbranch'' fbranch'' $ IfAttr rets'' ifsort allocInExp e = mapExpM alloc e where alloc =- identityMapper { mapOnBody = fail "Unhandled Body in ExplicitAllocations"- , mapOnRetType = fail "Unhandled RetType in ExplicitAllocations"- , mapOnBranchType = fail "Unhandled BranchType in ExplicitAllocations"- , mapOnFParam = fail "Unhandled FParam in ExplicitAllocations"- , mapOnLParam = fail "Unhandled LParam in ExplicitAllocations"+ identityMapper { mapOnBody = error "Unhandled Body in ExplicitAllocations"+ , mapOnRetType = error "Unhandled RetType in ExplicitAllocations"+ , mapOnBranchType = error "Unhandled BranchType in ExplicitAllocations"+ , mapOnFParam = error "Unhandled FParam in ExplicitAllocations"+ , mapOnLParam = error "Unhandled LParam in ExplicitAllocations" , mapOnOp = \op -> do handle <- asks allocInOp handle op }@@ -764,7 +757,7 @@ opSizeSubst :: PatternT attr -> op -> ChunkMap instance SizeSubst (HostOp lore op) where- opSizeSubst (Pattern _ [size]) (SplitSpace _ _ _ elems_per_thread) =+ opSizeSubst (Pattern _ [size]) (SizeOp (SplitSpace _ _ _ elems_per_thread)) = M.singleton (patElemName size) elems_per_thread opSizeSubst _ _ = mempty @@ -816,7 +809,7 @@ (inner -> Engine.SimpleM lore (Engine.OpWithWisdom inner, Stms (Engine.Wise lore))) -> SimpleOps lore simplifiable simplifyInnerOp =- SimpleOps mkExpAttrS' mkBodyS' mkLetNamesS' simplifyOp+ SimpleOps mkExpAttrS' mkBodyS' mkLetNamesS' protectOp simplifyOp where mkExpAttrS' _ pat e = return $ Engine.mkWiseExpAttr pat () e @@ -827,6 +820,14 @@ removeExpWisdom e return (mkWiseLetStm pat' (defAux ()) e, stms) where env = removeScopeWisdom $ ST.toScope vtable++ protectOp taken pat (Alloc size space) = Just $ do+ tbody <- resultBodyM [size]+ fbody <- resultBodyM [intConst Int64 0]+ size' <- letSubExp "hoisted_alloc_size" $+ If taken tbody fbody $ IfAttr [MemPrim int64] IfFallback+ letBind_ pat $ Op $ Alloc size' space+ protectOp _ _ _ = Nothing simplifyOp (Alloc size space) = (,) <$> (Alloc <$> Engine.simplify size <*> pure space) <*> pure mempty
src/Futhark/Pass/ExtractKernels.hs view
@@ -290,7 +290,7 @@ runBinder $ do to_what' <- letSubExp "comparatee" =<< foldBinOp (Mul Int32) (intConst Int32 1) to_what- cmp_res <- letSubExp desc $ Op $ CmpSizeLe size_key size_class to_what'+ cmp_res <- letSubExp desc $ Op $ SizeOp $ CmpSizeLe size_key size_class to_what' return (cmp_res, size_key) kernelAlternatives :: (MonadFreshNames m, HasScope Out.Kernels m) =>@@ -508,10 +508,16 @@ addStms stms letBind_ pat $ Op $ SegOp kernel -transformStm _ (Let orig_pat (StmAux cs _) (Op (GenReduce w ops bucket_fun imgs))) = do+transformStm _ (Let orig_pat (StmAux cs _) (Op (Hist w ops bucket_fun imgs))) = do let bfun' = soacsLambdaToKernels bucket_fun- genReduceKernel orig_pat [] [] cs w ops bfun' imgs + -- It is important not to launch unnecessarily many threads for+ -- histograms, because it may mean we unnecessarily need to reduce+ -- subhistograms as well.+ runBinder_ $ do+ lvl <- segThreadCapped [w] "seghist" $ NoRecommendation SegNoVirt+ addStms =<< histKernel lvl orig_pat [] [] cs w ops bfun' imgs+ transformStm _ bnd = runBinder_ $ FOT.transformStmRecursively bnd @@ -524,6 +530,7 @@ nestedParallelism = concatMap (parallelism . stmExp) . bodyStms where parallelism (Op (Scatter w _ _ _)) = [w] parallelism (Op (Screma w _ _)) = [w]+ parallelism (Op (Hist w _ _ _)) = [w] parallelism (Op (Stream w Sequential{} lam _)) | chunk_size_param : _ <- lambdaParams lam = let update (Var v) | v == paramName chunk_size_param = w@@ -638,7 +645,7 @@ addStms intra_prelude max_group_size <-- letSubExp "max_group_size" $ Op $ Out.GetSizeMax Out.SizeGroup+ letSubExp "max_group_size" $ Op $ SizeOp $ Out.GetSizeMax Out.SizeGroup fits <- letSubExp "fits" $ BasicOp $ CmpOp (CmpSle Int32) group_size max_group_size
src/Futhark/Pass/ExtractKernels/BlockedKernel.hs view
@@ -6,7 +6,7 @@ , segRed , nonSegRed , segScan- , segGenRed+ , segHist , segMap , streamRed@@ -51,22 +51,15 @@ String -> SizeClass -> m SubExp getSize desc size_class = do size_key <- nameFromString . pretty <$> newVName desc- letSubExp desc $ Op $ GetSize size_key size_class+ letSubExp desc $ Op $ SizeOp $ GetSize size_key size_class -numberOfGroups :: MonadBinder m => SubExp -> SubExp -> SubExp -> m (SubExp, SubExp)-numberOfGroups w group_size max_num_groups = do- -- If 'w' is small, we launch fewer groups than we normally would.- -- We don't want any idle groups.- w_div_group_size <- letSubExp "w_div_group_size" =<<- eDivRoundingUp Int64 (eSubExp w) (eSubExp group_size)- -- We also don't want zero groups.- num_groups_maybe_zero <- letSubExp "num_groups_maybe_zero" $ BasicOp $ BinOp (SMin Int64)- w_div_group_size max_num_groups+numberOfGroups :: (MonadBinder m, Op (Lore m) ~ HostOp (Lore m) inner) =>+ String -> SubExp -> SubExp -> m (SubExp, SubExp)+numberOfGroups desc w64 group_size = do+ max_num_groups_key <- nameFromString . pretty <$> newVName (desc ++ "_num_groups") num_groups <- letSubExp "num_groups" $- BasicOp $ BinOp (SMax Int64) (intConst Int64 1)- num_groups_maybe_zero- num_threads <-- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int64) num_groups group_size+ Op $ SizeOp $ CalcNumGroups w64 max_num_groups_key group_size+ num_threads <- letSubExp "num_threads" $ BasicOp $ BinOp (Mul Int32) num_groups group_size return (num_groups, num_threads) segThread :: (MonadBinder m, Op (Lore m) ~ HostOp (Lore m) inner) =>@@ -87,20 +80,21 @@ -- array. segThreadCapped :: MonadFreshNames m => MkSegLevel m segThreadCapped ws desc r = do- w <- letSubExp "nest_size" =<< foldBinOp (Mul Int32) (intConst Int32 1) ws+ w64 <- letSubExp "nest_size" =<<+ foldBinOp (Mul Int64) (intConst Int64 1) =<<+ mapM (asIntS Int64) ws group_size <- getSize (desc ++ "_group_size") SizeGroup case r of ManyThreads -> do- usable_groups <- letSubExp "segmap_usable_groups" =<<- eDivRoundingUp Int32 (eSubExp w) (eSubExp group_size)+ usable_groups <- letSubExp "segmap_usable_groups" .+ BasicOp . ConvOp (SExt Int64 Int32) =<<+ letSubExp "segmap_usable_groups_64" =<<+ eDivRoundingUp Int64 (eSubExp w64)+ (eSubExp =<< asIntS Int64 group_size) return $ SegThread (Count usable_groups) (Count group_size) SegNoVirt NoRecommendation v -> do- group_size_64 <- asIntS Int64 group_size- max_num_groups_64 <- asIntS Int64 =<< getSize (desc ++ "_max_num_groups") SizeNumGroups- w_64 <- asIntS Int64 w- (num_groups_64, _) <- numberOfGroups w_64 group_size_64 max_num_groups_64- num_groups <- asIntS Int32 num_groups_64+ (num_groups, _) <- numberOfGroups desc w64 group_size return $ SegThread (Count num_groups) (Count group_size) v mkSegSpace :: MonadFreshNames m => [(VName, SubExp)] -> m SegSpace@@ -235,7 +229,7 @@ -> [VName] -> m (SubExp, SegSpace, [Type], KernelBody Kernels) prepareStream size ispace w comm fold_lam nes arrs = do- let (KernelSize _ _ elems_per_thread _ num_threads) = size+ let (KernelSize elems_per_thread num_threads) = size let (ordering, split_ordering) = case comm of Commutative -> (Disorder, SplitStrided num_threads) Noncommutative -> (InOrder, SplitContiguous)@@ -271,7 +265,7 @@ -- The strategy here is to rephrase the stream reduction as a -- non-segmented SegRed that does explicit chunking within its body. -- First, figure out how many threads to use for this.- (_, size) <- blockedKernelSize =<< asIntS Int64 w+ size <- blockedKernelSize "stream_red" w let (redout_pes, mapout_pes) = splitAt (length nes) $ patternElements pat (redout_pat, ispace, read_dummy) <- dummyDim $ Pattern [] redout_pes@@ -291,7 +285,7 @@ -> Commutativity -> Lambda Kernels -> [SubExp] -> [VName] -> m ((SubExp, [VName]), Stms Kernels) streamMap out_desc mapout_pes w comm fold_lam nes arrs = runBinder $ do- (_, size) <- blockedKernelSize =<< asIntS Int64 w+ size <- blockedKernelSize "stream_map" w (threads, kspace, ts, kbody) <- prepareStream size [] w comm fold_lam nes arrs @@ -306,15 +300,16 @@ return (threads, map patElemName redout_pes) -segGenRed :: (MonadFreshNames m, HasScope Kernels m) =>- Pattern Kernels+segHist :: (MonadFreshNames m, HasScope Kernels m) =>+ SegLevel+ -> Pattern Kernels -> SubExp -> [(VName,SubExp)] -- ^ Segment indexes and sizes. -> [KernelInput]- -> [GenReduceOp Kernels]+ -> [HistOp Kernels] -> Lambda Kernels -> [VName] -> m (Stms Kernels)-segGenRed pat arr_w ispace inps ops lam arrs = runBinder_ $ do+segHist lvl pat arr_w ispace inps ops lam arrs = runBinder_ $ do gtid <- newVName "gtid" space <- mkSegSpace $ ispace ++ [(gtid, arr_w)] @@ -327,12 +322,7 @@ BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var gtid] map Returns <$> bodyBind (lambdaBody lam) - -- It is important not to launch unnecessarily many threads for- -- histograms, because it may mean we unnecessarily need to reduce- -- subhistograms as well.- lvl <- segThreadCapped (arr_w : map snd ispace) "seggenred" $ NoRecommendation SegNoVirt-- letBind_ pat $ Op $ SegOp $ SegGenRed lvl space ops (lambdaReturnType lam) kbody+ letBind_ pat $ Op $ SegOp $ SegHist lvl space ops (lambdaReturnType lam) kbody blockedPerThread :: (MonadBinder m, Lore m ~ Kernels) => VName -> SubExp -> KernelSize -> StreamOrd -> Lambda Kernels@@ -378,7 +368,7 @@ -> SplitOrdering -> SubExp -> SubExp -> SubExp -> [VName] -> m () splitArrays chunk_size split_bound ordering w i elems_per_i arrs = do- letBindNames_ [chunk_size] $ Op $ SplitSpace ordering w i elems_per_i+ letBindNames_ [chunk_size] $ Op $ SizeOp $ SplitSpace ordering w i elems_per_i case ordering of SplitContiguous -> do offset <- letSubExp "slice_offset" $ BasicOp $ BinOp (Mul Int32) i elems_per_i@@ -394,13 +384,7 @@ let slice = fullSlice arr_t [DimSlice i (Var chunk_size) stride] letBindNames_ [slice_name] $ BasicOp $ Index arr slice -data KernelSize = KernelSize { kernelWorkgroups :: SubExp- -- ^ Int32- , kernelWorkgroupSize :: SubExp- -- ^ Int32- , kernelElementsPerThread :: SubExp- -- ^ Int64- , kernelTotalElements :: SubExp+data KernelSize = KernelSize { kernelElementsPerThread :: SubExp -- ^ Int64 , kernelNumThreads :: SubExp -- ^ Int32@@ -408,23 +392,18 @@ deriving (Eq, Ord, Show) blockedKernelSize :: (MonadBinder m, Lore m ~ Kernels) =>- SubExp -> m (SubExp, KernelSize)-blockedKernelSize w = do- group_size <- getSize "group_size" SizeGroup- max_num_groups <- getSize "max_num_groups" SizeNumGroups+ String -> SubExp -> m KernelSize+blockedKernelSize desc w = do+ group_size <- getSize (desc ++ "_group_size") SizeGroup - group_size' <- asIntS Int64 group_size- max_num_groups' <- asIntS Int64 max_num_groups- (num_groups, num_threads) <- numberOfGroups w group_size' max_num_groups'- num_groups' <- asIntS Int32 num_groups- num_threads' <- asIntS Int32 num_threads+ w64 <- letSubExp "w64" $ BasicOp $ ConvOp (SExt Int32 Int64) w+ (_, num_threads) <- numberOfGroups desc w64 group_size per_thread_elements <- letSubExp "per_thread_elements" =<<- eDivRoundingUp Int64 (toExp =<< asIntS Int64 w) (toExp =<< asIntS Int64 num_threads)+ eDivRoundingUp Int64 (eSubExp w64) (toExp =<< asIntS Int64 num_threads) - return (max_num_groups,- KernelSize num_groups' group_size per_thread_elements w num_threads')+ return $ KernelSize per_thread_elements num_threads mapKernelSkeleton :: (HasScope Kernels m, MonadFreshNames m) => [(VName, SubExp)] -> [KernelInput]
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -15,7 +15,7 @@ , lambdaContainsParallelism , determineReduceOp , incrementalFlattening- , genReduceKernel+ , histKernel , DistEnv (..) , DistAcc (..)@@ -57,7 +57,7 @@ import Futhark.Transform.CopyPropagate import Futhark.Pass.ExtractKernels.Distribution import Futhark.Pass.ExtractKernels.ISRWIM-import Futhark.Pass.ExtractKernels.BlockedKernel hiding (segThread, segThreadCapped)+import Futhark.Pass.ExtractKernels.BlockedKernel hiding (segThread) import Futhark.Pass.ExtractKernels.Interchange import Futhark.Util import Futhark.Util.Log@@ -224,7 +224,7 @@ leavingNesting (MapLoop _ cs w lam arrs) acc = case popInnerTarget $ distTargets acc of Nothing ->- fail "The kernel targets list is unexpectedly small"+ error "The kernel targets list is unexpectedly small" Just ((pat,res), newtargets) -> do let acc' = acc { distTargets = newtargets } if null $ distStms acc'@@ -345,8 +345,8 @@ _ -> addStmToKernel bnd acc --- Parallelise segmented GenReduce.-maybeDistributeStm bnd@(Let pat (StmAux cs _) (Op (GenReduce w ops lam as))) acc =+-- Parallelise segmented Hist.+maybeDistributeStm bnd@(Let pat (StmAux cs _) (Op (Hist w ops lam as))) acc = distributeSingleStm acc bnd >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res ->@@ -354,7 +354,7 @@ let lam' = soacsLambdaToKernels lam nest' <- expandKernelNest pat_unused nest addKernels kernels- addKernel =<< segmentedGenReduceKernel nest' perm cs w ops lam' as+ addKernel =<< segmentedHistKernel nest' perm cs w ops lam' as return acc' _ -> addStmToKernel bnd acc@@ -381,7 +381,7 @@ _ -> addStmToKernel bnd acc --- If the reduction can be distributed by itself, we will turn it into a+-- if the reduction can be distributed by itself, we will turn it into a -- segmented reduce. -- -- If the reduction cannot be distributed by itself, it will be@@ -647,59 +647,69 @@ certifying cs $ letBind_ pat $ Op $ SegOp k where findInput kernel_inps a = maybe bad return $ find ((==a) . kernelInputName) kernel_inps- bad = fail "Ill-typed nested scatter encountered."+ bad = error "Ill-typed nested scatter encountered." inPlaceReturn ispace (aw, inp, is_vs) = WriteReturns (init ws++[aw]) (kernelInputArray inp) [ (map Var (init gtids)++[i], v) | (i,v) <- is_vs ] where (gtids,ws) = unzip ispace -segmentedGenReduceKernel :: MonadFreshNames m =>+segmentedHistKernel :: MonadFreshNames m => KernelNest -> [Int] -> Certificates -> SubExp- -> [SOAC.GenReduceOp SOACS]+ -> [SOAC.HistOp SOACS] -> Out.Lambda Out.Kernels -> [VName] -> DistNestT m KernelsStms-segmentedGenReduceKernel nest perm cs genred_w ops lam arrs = do+segmentedHistKernel nest perm cs hist_w ops lam arrs = do -- We replicate some of the checking done by 'isSegmentedOp', but- -- things are different because a GenReduce is not a reduction or+ -- things are different because a Hist is not a reduction or -- scan. (ispace, inputs) <- flatKernel nest let orig_pat = Pattern [] $ rearrangeShape perm $ patternValueElements $ loopNestingPattern $ fst nest -- The input/output arrays _must_ correspond to some kernel input,- -- or else the original nested GenReduce would have been ill-typed.+ -- or else the original nested Hist would have been ill-typed. -- Find them.- ops' <- forM ops $ \(SOAC.GenReduceOp num_bins dests nes op) ->- SOAC.GenReduceOp num_bins+ ops' <- forM ops $ \(SOAC.HistOp num_bins rf dests nes op) ->+ SOAC.HistOp num_bins rf <$> mapM (fmap kernelInputArray . findInput inputs) dests <*> pure nes <*> pure op- runBinder_ $ addStms =<<- genReduceKernel orig_pat ispace inputs cs genred_w ops' lam arrs++ mk_lvl <- asks distSegLevel+ scope <- askScope+ lift $ flip runBinderT_ scope $ do+ -- It is important not to launch unnecessarily many threads for+ -- histograms, because it may mean we unnecessarily need to reduce+ -- subhistograms as well.+ lvl <- mk_lvl (hist_w : map snd ispace) "seghist" $ NoRecommendation SegNoVirt+ addStms =<<+ histKernel lvl orig_pat ispace inputs cs hist_w ops' lam arrs where findInput kernel_inps a = maybe bad return $ find ((==a) . kernelInputName) kernel_inps- bad = fail "Ill-typed nested GenReduce encountered."+ bad = error "Ill-typed nested Hist encountered." -genReduceKernel :: (MonadFreshNames m, HasScope Out.Kernels m) =>- Pattern -> [(VName, SubExp)] -> [KernelInput]- -> Certificates -> SubExp -> [SOAC.GenReduceOp SOACS]+histKernel :: (MonadFreshNames m, HasScope Out.Kernels m) =>+ SegLevel -> Pattern -> [(VName, SubExp)] -> [KernelInput]+ -> Certificates -> SubExp -> [SOAC.HistOp SOACS] -> Out.Lambda Out.Kernels -> [VName] -> m KernelsStms-genReduceKernel orig_pat ispace inputs cs genred_w ops lam arrs = runBinder_ $ do- ops' <- forM ops $ \(SOAC.GenReduceOp num_bins dests nes op) -> do- (op', nes', shape) <- determineReduceOp op nes- return $ Out.GenReduceOp num_bins dests nes' shape op'+histKernel lvl orig_pat ispace inputs cs hist_w ops lam arrs =+ runBinder_ $ do+ ops' <- forM ops $ \(SOAC.HistOp num_bins rf dests nes op) -> do+ (op', nes', shape) <- determineReduceOp op nes+ return $ Out.HistOp num_bins rf dests nes' shape op' - let isDest = flip elem $ concatMap Out.genReduceDest ops'- inputs' = filter (not . isDest . kernelInputArray) inputs+ let isDest = flip elem $ concatMap Out.histDest ops'+ inputs' = filter (not . isDest . kernelInputArray) inputs - certifying cs $- addStms =<< segGenRed orig_pat genred_w ispace inputs' ops' lam arrs+ certifying cs $+ addStms =<< traverse renameStm =<<+ segHist lvl orig_pat hist_w ispace inputs' ops' lam arrs determineReduceOp :: (MonadBinder m, Lore m ~ Out.Kernels) => Lambda -> [SubExp] -> m (Out.Lambda Out.Kernels, [SubExp], Shape)@@ -711,7 +721,7 @@ let (shape, lam') = isVectorMap lam nes' <- forM ne_vs' $ \ne_v -> do ne_v_t <- lookupType ne_v- letSubExp "genred_ne" $+ letSubExp "hist_ne" $ BasicOp $ Index ne_v $ fullSlice ne_v_t $ replicate (shapeRank shape) $ DimFix $ intConst Int32 0 let lam'' = soacsLambdaToKernels lam'@@ -793,7 +803,7 @@ let indices = map fst ispace prepareNe (Var v) | v `nameIn` bound_by_nest =- fail "Neutral element bound in nest"+ fail "Neutral element bound in nest" prepareNe ne = return ne prepareArr arr =
src/Futhark/Pass/ExtractKernels/Distribution.hs view
@@ -335,7 +335,7 @@ createKernelNest (inner_nest, nests) distrib_body = do let Targets target targets = distributionTarget distrib_body unless (length nests == length targets) $- fail $ "Nests and targets do not match!\n" +++ error $ "Nests and targets do not match!\n" ++ "nests: " ++ ppNestings (inner_nest, nests) ++ "\ntargets:" ++ ppTargets (Targets target targets) runMaybeT $ fmap prepare $ recurse $ zip nests targets
src/Futhark/Pass/ExtractKernels/Intragroup.hs view
@@ -18,7 +18,7 @@ import Futhark.Analysis.PrimExp.Convert import Futhark.Representation.SOACS import qualified Futhark.Representation.Kernels as Out-import Futhark.Representation.Kernels.Kernel+import Futhark.Representation.Kernels.Kernel hiding (HistOp) import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Pass.ExtractKernels.DistributeNests@@ -82,7 +82,7 @@ letBindNames_ [group_size] =<< if null ws_min then eBinOp (SMin Int32)- (eSubExp =<< letSubExp "max_group_size" (Op $ Out.GetSizeMax Out.SizeGroup))+ (eSubExp =<< letSubExp "max_group_size" (Op $ SizeOp $ Out.GetSizeMax Out.SizeGroup)) (eSubExp intra_avail_par) else foldBinOp' (SMax Int32) ws_min @@ -203,6 +203,17 @@ map_lam' = soacsLambdaToKernels map_lam certifying (stmAuxCerts aux) $ addStms =<< segRed lvl' pat w [SegRedOp comm red_lam' nes mempty] map_lam' arrs [] []+ parallelMin [w]+++ Op (Hist w ops bucket_fun arrs) -> do+ ops' <- forM ops $ \(HistOp num_bins rf dests nes op) -> do+ (op', nes', shape) <- determineReduceOp op nes+ return $ Out.HistOp num_bins rf dests nes' shape op'++ let bucket_fun' = soacsLambdaToKernels bucket_fun+ certifying (stmAuxCerts aux) $+ addStms =<< segHist lvl' pat w [] [] ops' bucket_fun' arrs parallelMin [w] Op (Stream w (Sequential accs) lam arrs)
src/Futhark/Pass/KernelBabysitting.hs view
@@ -171,11 +171,10 @@ , mapOnOp = onOp ctx } mkSizeSubsts = fold . fmap mkStmSizeSubst- where mkStmSizeSubst (Let (Pattern [] [pe]) _ (Op (SplitSpace _ _ _ elems_per_i))) =+ where mkStmSizeSubst (Let (Pattern [] [pe]) _ (Op (SizeOp (SplitSpace _ _ _ elems_per_i)))) = M.singleton (patElemName pe) elems_per_i mkStmSizeSubst _ = mempty --- Not a hashmap, as SubExp is not hashable. type Replacements = M.Map (VName, Slice SubExp) VName ensureCoalescedAccess :: MonadBinder m =>@@ -210,7 +209,6 @@ -- If so, the access is already coalesced, nothing to do! -- (Cosmin's Heuristic.) | Just (Let _ _ (BasicOp (Rearrange perm _))) <- M.lookup arr expmap,- ---- Just (Just perm) <- nonlinearInMemory arr expmap, not $ null perm, not $ null thread_gids, inner_gid <- last thread_gids,@@ -219,7 +217,6 @@ DimFix inner_ind <- last slice', not $ null thread_gids, isGidVariant inner_gid inner_ind ->--- inner_ind == (Var $ inner_gid) -> return Nothing -- We are not fully indexing an array, but the remaining slice@@ -313,15 +310,19 @@ -- (because it would transpose a bigger array then needed -- big overhead). -- 2. the innermost index is variant to the innermost-thread gid -- (because access is likely to be already coalesced)+ -- 3. the indexes are a prefix of the thread indexes, because that+ -- means multiple threads will be accessing the same element. | any isCt is =- Nothing- | any (`nameIn` free_ker_vars) (mapMaybe mbVarId is) =- Nothing+ Nothing+ | any (`nameIn` free_ker_vars) (subExpVars is) =+ Nothing+ | is `isPrefixOf` tgids =+ Nothing | not (null tgids), not (null is), Var innergid <- last tgids, num_is > 0 && isGidVariant innergid (last is) =- Just is+ Just is -- 3. Otherwise try fix coalescing | otherwise = Just $ reverse $ foldl move (reverse is) $ zip [0..] (reverse tgids)@@ -349,9 +350,6 @@ isCt :: SubExp -> Bool isCt (Constant _) = True isCt (Var _) = False-- mbVarId (Constant _) = Nothing- mbVarId (Var v) = Just v coalescingPermutation :: Int -> Int -> [Int] coalescingPermutation num_is rank =
src/Futhark/Passes.hs view
@@ -55,6 +55,7 @@ , babysitKernels , tileLoops , unstream+ , performCSE True , simplifyKernels , inPlaceLowering ]
src/Futhark/Pkg/Info.hs view
@@ -26,14 +26,12 @@ import qualified Data.ByteString as BS import qualified Data.Text.Encoding as T import Data.List-import Data.Monoid ((<>)) import qualified System.FilePath.Posix as Posix import System.Exit import System.IO import qualified Codec.Archive.Zip as Zip import Data.Time (UTCTime, UTCTime, defaultTimeLocale, formatTime, getCurrentTime)-import Data.Versions (SemVer(..), semver, prettySemVer) import System.Process.ByteString (readProcessWithExitCode) import Network.HTTP.Client hiding (path) import Network.HTTP.Simple@@ -89,7 +87,7 @@ liftIO $ writeIORef ref $ Just v' return v' -downloadZipball :: (MonadLogger m, MonadIO m) =>+downloadZipball :: (MonadLogger m, MonadIO m, MonadFail m) => T.Text -> m Zip.Archive downloadZipball url = do logMsg $ "Downloading " <> T.unpack url@@ -126,7 +124,7 @@ -- repositories. For example, a package @github.com/user/repo@ will -- match version 0.* or 1.* tags only, a package -- @github.com/user/repo/v2@ will match 2.* tags, and so forth..-pkgInfo :: (MonadIO m, MonadLogger m) =>+pkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) => PkgPath -> m (Either T.Text (PkgInfo m)) pkgInfo path | ["github.com", owner, repo] <- T.splitOn "/" path =@@ -153,7 +151,7 @@ -- by other systems (Go most notably), so we should not be stepping on -- any toes. -gitCmd :: MonadIO m => [String] -> m BS.ByteString+gitCmd :: (MonadIO m, MonadFail m) => [String] -> m BS.ByteString gitCmd opts = do (code, out, err) <- liftIO $ readProcessWithExitCode "git" opts mempty liftIO $ BS.hPutStr stderr err@@ -166,7 +164,7 @@ -- couple of generic functions that are used to implement support for -- both. -ghglRevGetManifest :: (MonadIO m, MonadLogger m) =>+ghglRevGetManifest :: (MonadIO m, MonadLogger m, MonadFail m) => T.Text -> T.Text -> T.Text -> T.Text -> GetManifest m ghglRevGetManifest url owner repo tag = GetManifest $ do logMsg $ "Downloading package manifest from " <> url@@ -186,7 +184,7 @@ Right pm -> return pm x -> fail $ msg $ "got HTTP status " ++ show x -ghglLookupCommit :: (MonadIO m, MonadLogger m) =>+ghglLookupCommit :: (MonadIO m, MonadLogger m, MonadFail m) => T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> m (PkgRevInfo m) ghglLookupCommit archive_url manifest_url owner repo d ref hash = do@@ -195,7 +193,7 @@ time <- liftIO getCurrentTime -- FIXME return $ PkgRevInfo archive_url dir hash gd time -ghglPkgInfo :: (MonadIO m, MonadLogger m) =>+ghglPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) => T.Text -> (T.Text -> T.Text) -> (T.Text -> T.Text) -> T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m)) ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions = do@@ -226,7 +224,7 @@ return $ Just (v, pinfo) | otherwise = return Nothing -ghPkgInfo :: (MonadIO m, MonadLogger m) =>+ghPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) => T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m)) ghPkgInfo owner repo versions = ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions@@ -236,7 +234,7 @@ owner <> "/" <> repo <> "/" <> r <> "/" <> T.pack futharkPkg -glPkgInfo :: (MonadIO m, MonadLogger m) =>+glPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) => T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m)) glPkgInfo owner repo versions = ghglPkgInfo repo_url mk_archive_url mk_manifest_url owner repo versions@@ -266,7 +264,7 @@ -- | Monads that support a stateful package registry. These are also -- required to be instances of 'MonadIO' because most package registry -- operations involve network operations.-class (MonadIO m, MonadLogger m) => MonadPkgRegistry m where+class (MonadIO m, MonadLogger m, MonadFail m) => MonadPkgRegistry m where getPkgRegistry :: m (PkgRegistry m) putPkgRegistry :: PkgRegistry m -> m () modifyPkgRegistry :: (PkgRegistry m -> PkgRegistry m) -> m ()
src/Futhark/Pkg/Solve.hs view
@@ -15,7 +15,6 @@ import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Text as T-import Data.Monoid ((<>)) import Control.Monad.Free.Church
src/Futhark/Pkg/Types.hs view
@@ -48,7 +48,7 @@ import System.FilePath import qualified System.FilePath.Posix as Posix -import Data.Versions (SemVer(..), VUnit(..), prettySemVer)+import Data.Versions (semver, SemVer(..), VUnit(..), prettySemVer) import Text.Megaparsec hiding (many, some) import Text.Megaparsec.Char
src/Futhark/Representation/AST/Annotations.hs view
@@ -5,6 +5,8 @@ ) where +import qualified Data.Kind+ import Futhark.Representation.AST.Syntax.Core import Futhark.Representation.AST.RetType import Futhark.Representation.AST.Attributes.Types@@ -17,29 +19,29 @@ DeclTyped (FParamAttr l)) => Annotations l where -- | Annotation for every let-pattern element.- type LetAttr l :: *+ type LetAttr l :: Data.Kind.Type type LetAttr l = Type -- | Annotation for every expression.- type ExpAttr l :: *+ type ExpAttr l :: Data.Kind.Type type ExpAttr l = () -- | Annotation for every body.- type BodyAttr l :: *+ type BodyAttr l :: Data.Kind.Type type BodyAttr l = () -- | Annotation for every (non-lambda) function parameter.- type FParamAttr l :: *+ type FParamAttr l :: Data.Kind.Type type FParamAttr l = DeclType -- | Annotation for every lambda function parameter.- type LParamAttr l :: *+ type LParamAttr l :: Data.Kind.Type type LParamAttr l = Type -- | The return type annotation of function calls.- type RetType l :: *+ type RetType l :: Data.Kind.Type type RetType l = DeclExtType -- | The return type annotation of branches.- type BranchType l :: *+ type BranchType l :: Data.Kind.Type type BranchType l = ExtType -- | Extensible operation.- type Op l :: *+ type Op l :: Data.Kind.Type type Op l = ()
src/Futhark/Representation/AST/Attributes.hs view
@@ -40,7 +40,6 @@ import Data.List import Data.Maybe (mapMaybe, isJust)-import Data.Monoid ((<>)) import qualified Data.Map.Strict as M import Futhark.Representation.AST.Attributes.Reshape@@ -106,6 +105,7 @@ safeBasicOp Scratch{} = True safeBasicOp Concat{} = True safeBasicOp Reshape{} = True+ safeBasicOp Rearrange{} = True safeBasicOp Manifest{} = True safeBasicOp Iota{} = True safeBasicOp Replicate{} = True
src/Futhark/Representation/AST/Attributes/Aliases.hs view
@@ -19,7 +19,7 @@ where import Control.Arrow (first)-import Data.Monoid ((<>))+import qualified Data.Kind import Futhark.Representation.AST.Attributes (IsOp) import Futhark.Representation.AST.Syntax@@ -160,7 +160,7 @@ consumedInOp () = mempty class AliasedOp (OpWithAliases op) => CanBeAliased op where- type OpWithAliases op :: *+ type OpWithAliases op :: Data.Kind.Type removeOpAliases :: OpWithAliases op -> op addOpAliases :: op -> OpWithAliases op
src/Futhark/Representation/AST/Attributes/Ranges.hs view
@@ -22,7 +22,7 @@ ) where -import Data.Monoid ((<>))+import qualified Data.Kind import qualified Data.Map.Strict as M import Futhark.Representation.AST.Attributes@@ -260,7 +260,7 @@ class RangedOp (OpWithRanges op) => CanBeRanged op where- type OpWithRanges op :: *+ type OpWithRanges op :: Data.Kind.Type removeOpRanges :: OpWithRanges op -> op addOpRanges :: op -> OpWithRanges op
src/Futhark/Representation/AST/Attributes/Reshape.hs view
@@ -179,3 +179,5 @@ sliceSizes [] = [1] sliceSizes (n:ns) = product (n : ns) : sliceSizes ns++{- HLINT ignore sliceSizes -}
src/Futhark/Representation/AST/Attributes/Types.hs view
@@ -69,7 +69,6 @@ import Control.Monad.State import Data.Maybe-import Data.Monoid ((<>)) import Data.List (elemIndex, foldl') import qualified Data.Set as S import qualified Data.Map.Strict as M
src/Futhark/Representation/AST/Pretty.hs view
@@ -17,10 +17,8 @@ where import Data.Maybe-import Data.Monoid ((<>)) import Futhark.Util.Pretty- import Futhark.Representation.AST.Attributes.Patterns import Futhark.Representation.AST.Syntax @@ -282,7 +280,7 @@ ppPattern :: (Pretty a, Pretty b) => [a] -> [b] -> Doc ppPattern [] bs = braces $ commasep $ map ppr bs-ppPattern as bs = braces $ commasep (map ppr as) <> semi <+> commasep (map ppr bs)+ppPattern as bs = braces $ commasep (map ppr as) <> semi </> commasep (map ppr bs) ppTuple' :: Pretty a => [a] -> Doc ppTuple' ets = braces $ commasep $ map ppr ets
src/Futhark/Representation/AST/Syntax/Core.hs view
@@ -51,7 +51,6 @@ import Control.Monad.State import Data.Maybe-import Data.Monoid ((<>)) import Data.String import qualified Data.Map.Strict as M import Data.Traversable
src/Futhark/Representation/AST/Traversals.hs view
@@ -43,7 +43,6 @@ import Control.Monad.Identity import qualified Data.Traversable import Data.Foldable (traverse_)-import Data.Monoid ((<>)) import Futhark.Representation.AST.Syntax import Futhark.Representation.AST.Attributes.Scope
src/Futhark/Representation/Aliases.hs view
@@ -43,7 +43,6 @@ import Control.Monad.Reader import Data.Foldable import Data.Maybe-import Data.Monoid ((<>)) import qualified Data.Map.Strict as M import Futhark.Representation.AST.Syntax
src/Futhark/Representation/ExplicitMemory.hs view
@@ -100,7 +100,6 @@ import qualified Data.Map.Strict as M import Data.Foldable (traverse_) import Data.List-import Data.Monoid ((<>)) import Futhark.Analysis.Metrics import Futhark.Representation.AST.Syntax@@ -204,7 +203,7 @@ opMetrics (Inner k) = opMetrics k instance IsOp inner => IsOp (MemOp inner) where- safeOp Alloc{} = True+ safeOp Alloc{} = False safeOp (Inner k) = safeOp k cheapOp (Inner k) = cheapOp k cheapOp Alloc{} = True@@ -734,7 +733,7 @@ MemArray _ _ _ (ArrayIn mem ixfun) -> return (mem, ixfun) _ ->- fail $ "Variable " ++ pretty name ++ " does not look like an array."+ error $ "Variable " ++ pretty name ++ " does not look like an array." checkMemInfo :: TC.Checkable lore => VName -> MemInfo SubExp u MemBind@@ -842,7 +841,7 @@ MemArray et shape _ (ArrayIn mem ixfun) -> return (et, Shape $ shapeDims shape, mem, ixfun) _ ->- fail $ "arrayVarReturns: " ++ pretty v ++ " is not an array."+ error $ "arrayVarReturns: " ++ pretty v ++ " is not an array." varReturns :: (HasScope lore m, Monad m, ExplicitMemorish lore) => VName -> m ExpReturns@@ -927,11 +926,11 @@ Just $ ReturnsInBlock mem ixfun') where ixfun' = existentialiseIxFun (map paramName mergevars) ixfun (Array{}, _) ->- fail "expReturns: Array return type but not array merge variable."+ error "expReturns: Array return type but not array merge variable." (Prim bt, _) -> return $ MemPrim bt (Mem{}, _) ->- fail "expReturns: loop returns memory block explicitly."+ error "expReturns: loop returns memory block explicitly." isMergeVar v = find ((==v) . paramName . snd) $ zip [0..] mergevars mergevars = map fst $ ctx ++ val @@ -969,8 +968,8 @@ kernelBodyReturns kbody =<< (extReturns <$> opType k) segOpReturns k@(SegScan _ _ _ _ _ kbody) = kernelBodyReturns kbody =<< (extReturns <$> opType k)-segOpReturns (SegGenRed _ _ ops _ _) =- concat <$> mapM (mapM varReturns . genReduceDest) ops+segOpReturns (SegHist _ _ ops _ _) =+ concat <$> mapM (mapM varReturns . histDest) ops kernelBodyReturns :: (HasScope ExplicitMemory m, Monad m) => KernelBody ExplicitMemory -> [ExpReturns] -> m [ExpReturns]
src/Futhark/Representation/Kernels.hs view
@@ -21,7 +21,7 @@ import Futhark.Representation.AST.Attributes import Futhark.Representation.AST.Traversals import Futhark.Representation.AST.Pretty-import Futhark.Representation.SOACS.SOAC hiding (GenReduceOp(..))+import Futhark.Representation.SOACS.SOAC hiding (HistOp(..)) import Futhark.Binder import Futhark.Construct import qualified Futhark.TypeCheck as TypeCheck
src/Futhark/Representation/Kernels/Kernel.hs view
@@ -8,7 +8,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} module Futhark.Representation.Kernels.Kernel- ( GenReduceOp(..)+ ( HistOp(..)+ , histType , SegRedOp(..) , segRedResults , KernelBody(..)@@ -35,6 +36,9 @@ , identitySegOpWalker , walkSegOpM + -- * Size operations+ , SizeOp(..)+ -- * Host operations , HostOp(..) , typeCheckHostOp@@ -96,20 +100,29 @@ rename (SplitStrided stride) = SplitStrided <$> rename stride -data GenReduceOp lore =- GenReduceOp { genReduceWidth :: SubExp- , genReduceDest :: [VName]- , genReduceNeutral :: [SubExp]- , genReduceShape :: Shape- -- ^ In case this operator is semantically a- -- vectorised operator (corresponding to a perfect map- -- nest in the SOACS representation), these are the- -- logical "dimensions". This is used to generate- -- more efficient code.- , genReduceOp :: LambdaT lore- }+data HistOp lore =+ HistOp { histWidth :: SubExp+ , histRaceFactor :: SubExp+ , histDest :: [VName]+ , histNeutral :: [SubExp]+ , histShape :: Shape+ -- ^ In case this operator is semantically a vectorised+ -- operator (corresponding to a perfect map nest in the+ -- SOACS representation), these are the logical+ -- "dimensions". This is used to generate more efficient+ -- code.+ , histOp :: Lambda lore+ } deriving (Eq, Ord, Show) +-- | The type of a histogram produced by a 'HistOp'. This can be+-- different from the type of the 'HistDest's in case we are+-- dealing with a segmented histogram.+histType :: HistOp lore -> [Type]+histType op = map ((`arrayOfRow` histWidth op) .+ (`arrayOfShape` histShape op)) $+ lambdaReturnType $ histOp op+ data SegRedOp lore = SegRedOp { segRedComm :: Commutativity , segRedLambda :: Lambda lore@@ -367,20 +380,20 @@ -- ^ The KernelSpace must always have at least two dimensions, -- implying that the result of a SegRed is always an array. | SegScan SegLevel SegSpace (Lambda lore) [SubExp] [Type] (KernelBody lore)- | SegGenRed SegLevel SegSpace [GenReduceOp lore] [Type] (KernelBody lore)+ | SegHist SegLevel SegSpace [HistOp lore] [Type] (KernelBody lore) deriving (Eq, Ord, Show) segLevel :: SegOp lore -> SegLevel segLevel (SegMap lvl _ _ _) = lvl segLevel (SegRed lvl _ _ _ _) = lvl segLevel (SegScan lvl _ _ _ _ _) = lvl-segLevel (SegGenRed lvl _ _ _ _) = lvl+segLevel (SegHist lvl _ _ _ _) = lvl segSpace :: SegOp lore -> SegSpace segSpace (SegMap _ lvl _ _) = lvl segSpace (SegRed _ lvl _ _ _) = lvl segSpace (SegScan _ lvl _ _ _ _) = lvl-segSpace (SegGenRed _ lvl _ _ _) = lvl+segSpace (SegHist _ lvl _ _ _) = lvl segResultShape :: SegSpace -> Type -> KernelResult -> Type segResultShape _ t (WriteReturns rws _ _) =@@ -411,10 +424,10 @@ (drop (length scan_ts) $ kernelBodyResult kbody) where dims = segSpaceDims space (scan_ts, map_ts) = splitAt (length nes) ts-segOpType (SegGenRed _ space ops _ _) = do+segOpType (SegHist _ space ops _ _) = do op <- ops- let shape = Shape (segment_dims <> [genReduceWidth op]) <> genReduceShape op- map (`arrayOfShape` shape) (lambdaReturnType $ genReduceOp op)+ let shape = Shape (segment_dims <> [histWidth op]) <> histShape op+ map (`arrayOfShape` shape) (lambdaReturnType $ histOp op) where dims = segSpaceDims space segment_dims = init dims @@ -430,8 +443,8 @@ consumedInKernelBody kbody consumedInOp (SegScan _ _ _ _ _ kbody) = consumedInKernelBody kbody- consumedInOp (SegGenRed _ _ ops _ kbody) =- namesFromList (concatMap genReduceDest ops) <> consumedInKernelBody kbody+ consumedInOp (SegHist _ _ ops _ kbody) =+ namesFromList (concatMap histDest ops) <> consumedInKernelBody kbody checkSegLevel :: Maybe SegLevel -> SegLevel -> TC.TypeM lore () checkSegLevel Nothing SegThreadScalar{} =@@ -469,12 +482,13 @@ typeCheckSegOp cur_lvl (SegScan lvl space scan_op nes ts body) = checkScanRed cur_lvl lvl space [(scan_op, nes, mempty)] ts body -typeCheckSegOp cur_lvl (SegGenRed lvl space ops ts kbody) = do+typeCheckSegOp cur_lvl (SegHist lvl space ops ts kbody) = do checkSegBasics cur_lvl lvl space ts TC.binding (scopeOfSegSpace space) $ do- nes_ts <- forM ops $ \(GenReduceOp dest_w dests nes shape op) -> do+ nes_ts <- forM ops $ \(HistOp dest_w rf dests nes shape op) -> do TC.require [Prim int32] dest_w+ TC.require [Prim int32] rf nes' <- mapM TC.checkArg nes mapM_ (TC.require [Prim int32]) $ shapeDims shape @@ -483,7 +497,7 @@ TC.checkLambda op $ map (TC.noArgAliases . first stripVecDims) $ nes' ++ nes' let nes_t = map TC.argType nes' unless (nes_t == lambdaReturnType op) $- TC.bad $ TC.TypeError $ "SegGenRed operator has return type " +++ TC.bad $ TC.TypeError $ "SegHist operator has return type " ++ prettyTuple (lambdaReturnType op) ++ " but neutral element has type " ++ prettyTuple nes_t @@ -501,7 +515,7 @@ -- operation followed by the values to write. let bucket_ret_t = replicate (length ops) (Prim int32) ++ concat nes_ts unless (bucket_ret_t == ts) $- TC.bad $ TC.TypeError $ "SegGenRed body has return type " +++ TC.bad $ TC.TypeError $ "SegHist body has return type " ++ prettyTuple ts ++ " but should have type " ++ prettyTuple bucket_ret_t @@ -591,15 +605,16 @@ <*> mapM (mapOnSegOpSubExp tv) nes <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts <*> mapOnSegOpBody tv body-mapSegOpM tv (SegGenRed lvl space ops ts body) =- SegGenRed+mapSegOpM tv (SegHist lvl space ops ts body) =+ SegHist <$> mapOnSegLevel tv lvl <*> mapOnSegSpace tv space- <*> mapM onGenRedOp ops+ <*> mapM onHistOp ops <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts <*> mapOnSegOpBody tv body- where onGenRedOp (GenReduceOp w arrs nes shape op) =- GenReduceOp <$> mapOnSegOpSubExp tv w+ where onHistOp (HistOp w rf arrs nes shape op) =+ HistOp <$> mapOnSegOpSubExp tv w+ <*> mapOnSegOpSubExp tv rf <*> mapM (mapOnSegOpVName tv) arrs <*> mapM (mapOnSegOpSubExp tv) nes <*> (Shape <$> mapM (mapOnSegOpSubExp tv) (shapeDims shape))@@ -694,9 +709,9 @@ kernelBodyMetrics body opMetrics (SegScan _ _ scan_op _ _ body) = inside "SegScan" $ lambdaMetrics scan_op >> kernelBodyMetrics body- opMetrics (SegGenRed _ _ ops _ body) =- inside "SegGenRed" $ do mapM_ (lambdaMetrics . genReduceOp) ops- kernelBodyMetrics body+ opMetrics (SegHist _ _ ops _ body) =+ inside "SegHist" $ do mapM_ (lambdaMetrics . histOp) ops+ kernelBodyMetrics body instance Pretty SegSpace where ppr (SegSpace phys dims) = parens (commasep $ do (i,d) <- dims@@ -745,14 +760,14 @@ PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> PP.nestedBlock "{" "}" (ppr body) - ppr (SegGenRed lvl space ops ts body) =- text "seggenred_" <> ppr lvl </>+ ppr (SegHist lvl space ops ts body) =+ text "seghist_" <> ppr lvl </> ppSegLevel lvl </> PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops)) </> PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> PP.nestedBlock "{" "}" (ppr body)- where ppOp (GenReduceOp w dests nes shape op) =- ppr w <> PP.comma </>+ where ppOp (HistOp w rf dests nes shape op) =+ ppr w <> PP.comma <+> ppr rf <> PP.comma </> PP.braces (PP.commasep $ map ppr dests) <> PP.comma </> PP.braces (PP.commasep $ map ppr nes) <> PP.comma </> ppr shape <> PP.comma </>@@ -824,8 +839,8 @@ --- Host operations --- | A host-level operation; parameterised by what else it can do.-data HostOp lore op+-- | A simple size-level query or computation.+data SizeOp = SplitSpace SplitOrdering SubExp SubExp SubExp -- ^ @SplitSpace o w i elems_per_thread@. --@@ -853,17 +868,15 @@ | GetSizeMax SizeClass -- ^ The maximum size of some class. | CmpSizeLe Name SizeClass SubExp- -- ^ Compare size (likely a threshold) with some Int32 value.- | SegOp (SegOp lore)- -- ^ A segmented operation.- | OtherOp op+ -- ^ Compare size (likely a threshold) with some integer value.+ | CalcNumGroups SubExp Name SubExp+ -- ^ @CalcNumGroups w max_num_groups group_size@ calculates the+ -- number of GPU workgroups to use for an input of the given size.+ -- The @Name@ is a size name. Note that @w@ is an i64 to avoid+ -- overflow issues. deriving (Eq, Ord, Show) -instance (Attributes lore, Substitute op) => Substitute (HostOp lore op) where- substituteNames substs (SegOp op) =- SegOp $ substituteNames substs op- substituteNames substs (OtherOp op) =- OtherOp $ substituteNames substs op+instance Substitute SizeOp where substituteNames subst (SplitSpace o w i elems_per_thread) = SplitSpace (substituteNames subst o)@@ -871,110 +884,176 @@ (substituteNames subst i) (substituteNames subst elems_per_thread) substituteNames substs (CmpSizeLe name sclass x) =- CmpSizeLe name sclass $ substituteNames substs x- substituteNames _ x = x+ CmpSizeLe name sclass (substituteNames substs x)+ substituteNames substs (CalcNumGroups w max_num_groups group_size) =+ CalcNumGroups+ (substituteNames substs w)+ max_num_groups+ (substituteNames substs group_size)+ substituteNames _ op = op -instance (Attributes lore, Rename op) => Rename (HostOp lore op) where+instance Rename SizeOp where rename (SplitSpace o w i elems_per_thread) = SplitSpace <$> rename o <*> rename w <*> rename i <*> rename elems_per_thread+ rename (CmpSizeLe name sclass x) =+ CmpSizeLe name sclass <$> rename x+ rename (CalcNumGroups w max_num_groups group_size) =+ CalcNumGroups <$> rename w <*> pure max_num_groups <*> rename group_size+ rename x = pure x++instance IsOp SizeOp where+ safeOp _ = True+ cheapOp _ = True++instance TypedOp SizeOp where+ opType SplitSpace{} = pure [Prim int32]+ opType (GetSize _ _) = pure [Prim int32]+ opType (GetSizeMax _) = pure [Prim int32]+ opType CmpSizeLe{} = pure [Prim Bool]+ opType CalcNumGroups{} = pure [Prim int32]++instance AliasedOp SizeOp where+ opAliases _ = [mempty]+ consumedInOp _ = mempty++instance RangedOp SizeOp where+ opRanges (SplitSpace _ _ _ elems_per_thread) =+ [(Just (ScalarBound 0),+ Just (ScalarBound (SE.subExpToScalExp elems_per_thread int32)))]+ opRanges _ = [unknownRange]++instance FreeIn SizeOp where+ freeIn' (SplitSpace o w i elems_per_thread) =+ freeIn' o <> freeIn' [w, i, elems_per_thread]+ freeIn' (CmpSizeLe _ _ x) = freeIn' x+ freeIn' (CalcNumGroups w _ group_size) = freeIn' w <> freeIn' group_size+ freeIn' _ = mempty++instance PP.Pretty SizeOp where+ ppr (SplitSpace o w i elems_per_thread) =+ text "splitSpace" <> suff <>+ parens (commasep [ppr w, ppr i, ppr elems_per_thread])+ where suff = case o of SplitContiguous -> mempty+ SplitStrided stride -> text "Strided" <> parens (ppr stride)++ ppr (GetSize name size_class) =+ text "get_size" <> parens (commasep [ppr name, ppr size_class])++ ppr (GetSizeMax size_class) =+ text "get_size_max" <> parens (commasep [ppr size_class])++ ppr (CmpSizeLe name size_class x) =+ text "get_size" <> parens (commasep [ppr name, ppr size_class]) <+>+ text "<=" <+> ppr x++ ppr (CalcNumGroups w max_num_groups group_size) =+ text "calc_num_groups" <> parens (commasep [ppr w, ppr max_num_groups, ppr group_size])++instance OpMetrics SizeOp where+ opMetrics SplitSpace{} = seen "SplitSpace"+ opMetrics GetSize{} = seen "GetSize"+ opMetrics GetSizeMax{} = seen "GetSizeMax"+ opMetrics CmpSizeLe{} = seen "CmpSizeLe"+ opMetrics CalcNumGroups{} = seen "CalcNumGroups"++typeCheckSizeOp :: TC.Checkable lore => SizeOp -> TC.TypeM lore ()+typeCheckSizeOp (SplitSpace o w i elems_per_thread) = do+ case o of+ SplitContiguous -> return ()+ SplitStrided stride -> TC.require [Prim int32] stride+ mapM_ (TC.require [Prim int32]) [w, i, elems_per_thread]+typeCheckSizeOp GetSize{} = return ()+typeCheckSizeOp GetSizeMax{} = return ()+typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require [Prim int32] x+typeCheckSizeOp (CalcNumGroups w _ group_size) = do TC.require [Prim int64] w+ TC.require [Prim int32] group_size++-- | A host-level operation; parameterised by what else it can do.+data HostOp lore op+ = SegOp (SegOp lore)+ -- ^ A segmented operation.+ | SizeOp SizeOp+ | OtherOp op+ deriving (Eq, Ord, Show)++instance (Attributes lore, Substitute op) => Substitute (HostOp lore op) where+ substituteNames substs (SegOp op) =+ SegOp $ substituteNames substs op+ substituteNames substs (OtherOp op) =+ OtherOp $ substituteNames substs op+ substituteNames substs (SizeOp op) =+ SizeOp $ substituteNames substs op++instance (Attributes lore, Rename op) => Rename (HostOp lore op) where rename (SegOp op) = SegOp <$> rename op rename (OtherOp op) = OtherOp <$> rename op- rename (CmpSizeLe name sclass x) = CmpSizeLe name sclass <$> rename x- rename x = pure x+ rename (SizeOp op) = SizeOp <$> rename op instance (Attributes lore, IsOp op) => IsOp (HostOp lore op) where safeOp (SegOp op) = safeOp op safeOp (OtherOp op) = safeOp op- safeOp _ = True+ safeOp (SizeOp op) = safeOp op+ cheapOp (SegOp op) = cheapOp op cheapOp (OtherOp op) = cheapOp op- cheapOp _ = True+ cheapOp (SizeOp op) = cheapOp op instance TypedOp op => TypedOp (HostOp lore op) where- opType SplitSpace{} = pure [Prim int32]- opType GetSize{} = pure [Prim int32]- opType GetSizeMax{} = pure [Prim int32]- opType CmpSizeLe{} = pure [Prim Bool] opType (SegOp op) = opType op opType (OtherOp op) = opType op+ opType (SizeOp op) = opType op instance (Aliased lore, AliasedOp op, Attributes lore) => AliasedOp (HostOp lore op) where opAliases (SegOp op) = opAliases op opAliases (OtherOp op) = opAliases op- opAliases _ = [mempty]+ opAliases (SizeOp op) = opAliases op consumedInOp (SegOp op) = consumedInOp op consumedInOp (OtherOp op) = consumedInOp op- consumedInOp _ = mempty+ consumedInOp (SizeOp op) = consumedInOp op instance (Attributes lore, RangedOp op) => RangedOp (HostOp lore op) where- opRanges (SplitSpace _ _ _ elems_per_thread) =- [(Just (ScalarBound 0),- Just (ScalarBound (SE.subExpToScalExp elems_per_thread int32)))] opRanges (SegOp op) = opRanges op opRanges (OtherOp op) = opRanges op- opRanges _ = [unknownRange]+ opRanges (SizeOp op) = opRanges op instance (Attributes lore, FreeIn op) => FreeIn (HostOp lore op) where- freeIn' (SplitSpace o w i elems_per_thread) =- freeIn' o <> freeIn' [w, i, elems_per_thread] freeIn' (SegOp op) = freeIn' op freeIn' (OtherOp op) = freeIn' op- freeIn' (CmpSizeLe _ _ x) = freeIn' x- freeIn' _ = mempty+ freeIn' (SizeOp op) = freeIn' op instance (CanBeAliased (Op lore), CanBeAliased op, Attributes lore) => CanBeAliased (HostOp lore op) where type OpWithAliases (HostOp lore op) = HostOp (Aliases lore) (OpWithAliases op) - addOpAliases (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread addOpAliases (SegOp op) = SegOp $ addOpAliases op addOpAliases (OtherOp op) = OtherOp $ addOpAliases op- addOpAliases (GetSize name sclass) = GetSize name sclass- addOpAliases (GetSizeMax sclass) = GetSizeMax sclass- addOpAliases (CmpSizeLe name sclass x) = CmpSizeLe name sclass x+ addOpAliases (SizeOp op) = SizeOp op - removeOpAliases (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread removeOpAliases (SegOp op) = SegOp $ removeOpAliases op removeOpAliases (OtherOp op) = OtherOp $ removeOpAliases op- removeOpAliases (GetSize name sclass) = GetSize name sclass- removeOpAliases (GetSizeMax sclass) = GetSizeMax sclass- removeOpAliases (CmpSizeLe name sclass x) = CmpSizeLe name sclass x+ removeOpAliases (SizeOp op) = SizeOp op instance (CanBeRanged (Op lore), CanBeRanged op, Attributes lore) => CanBeRanged (HostOp lore op) where type OpWithRanges (HostOp lore op) = HostOp (Ranges lore) (OpWithRanges op) - addOpRanges (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread addOpRanges (SegOp op) = SegOp $ addOpRanges op addOpRanges (OtherOp op) = OtherOp $ addOpRanges op- addOpRanges (GetSize name sclass) = GetSize name sclass- addOpRanges (GetSizeMax sclass) = GetSizeMax sclass- addOpRanges (CmpSizeLe name sclass x) = CmpSizeLe name sclass x+ addOpRanges (SizeOp op) = SizeOp op - removeOpRanges (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread removeOpRanges (SegOp op) = SegOp $ removeOpRanges op removeOpRanges (OtherOp op) = OtherOp $ removeOpRanges op- removeOpRanges (GetSize name sclass) = GetSize name sclass- removeOpRanges (GetSizeMax sclass) = GetSizeMax sclass- removeOpRanges (CmpSizeLe name sclass x) = CmpSizeLe name sclass x+ removeOpRanges (SizeOp op) = SizeOp op instance (CanBeWise (Op lore), CanBeWise op, Attributes lore) => CanBeWise (HostOp lore op) where type OpWithWisdom (HostOp lore op) = HostOp (Wise lore) (OpWithWisdom op) - removeOpWisdom (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread removeOpWisdom (SegOp op) = SegOp $ removeOpWisdom op- removeOpWisdom (GetSize name sclass) = GetSize name sclass- removeOpWisdom (GetSizeMax sclass) = GetSizeMax sclass- removeOpWisdom (CmpSizeLe name sclass x) = CmpSizeLe name sclass x removeOpWisdom (OtherOp op) = OtherOp $ removeOpWisdom op+ removeOpWisdom (SizeOp op) = SizeOp op instance (Attributes lore, ST.IndexOp op) => ST.IndexOp (HostOp lore op) where indexOp vtable k (SegOp op) is = ST.indexOp vtable k op is@@ -982,33 +1061,14 @@ indexOp _ _ _ _ = Nothing instance (PrettyLore lore, PP.Pretty op) => PP.Pretty (HostOp lore op) where- ppr (SplitSpace o w i elems_per_thread) =- text "splitSpace" <> suff <>- parens (commasep [ppr w, ppr i, ppr elems_per_thread])- where suff = case o of SplitContiguous -> mempty- SplitStrided stride -> text "Strided" <> parens (ppr stride)-- ppr (GetSize name size_class) =- text "get_size" <> parens (commasep [ppr name, ppr size_class])-- ppr (GetSizeMax size_class) =- text "get_size_max" <> parens (ppr size_class)-- ppr (CmpSizeLe name size_class x) =- text "get_size" <> parens (commasep [ppr name, ppr size_class]) <+>- text "<=" <+> ppr x- ppr (SegOp op) = ppr op- ppr (OtherOp op) = ppr op+ ppr (SizeOp op) = ppr op instance (OpMetrics (Op lore), OpMetrics op) => OpMetrics (HostOp lore op) where- opMetrics SplitSpace{} = seen "SplitSpace"- opMetrics GetSize{} = seen "GetSize"- opMetrics GetSizeMax{} = seen "GetSizeMax"- opMetrics CmpSizeLe{} = seen "CmpSizeLe" opMetrics (SegOp op) = opMetrics op opMetrics (OtherOp op) = opMetrics op+ opMetrics (SizeOp op) = opMetrics op typeCheckHostOp :: TC.Checkable lore => (SegLevel -> OpWithAliases (Op lore) -> TC.TypeM lore ())@@ -1016,15 +1076,8 @@ -> (op -> TC.TypeM lore ()) -> HostOp (Aliases lore) op -> TC.TypeM lore ()-typeCheckHostOp _ _ _ (SplitSpace o w i elems_per_thread) = do- case o of- SplitContiguous -> return ()- SplitStrided stride -> TC.require [Prim int32] stride- mapM_ (TC.require [Prim int32]) [w, i, elems_per_thread]-typeCheckHostOp _ _ _ GetSize{} = return ()-typeCheckHostOp _ _ _ GetSizeMax{} = return ()-typeCheckHostOp _ _ _ (CmpSizeLe _ _ x) = TC.require [Prim int32] x typeCheckHostOp checker lvl _ (SegOp op) = TC.checkOpWith (checker $ segLevel op) $ typeCheckSegOp lvl op typeCheckHostOp _ _ f (OtherOp op) = f op+typeCheckHostOp _ _ _ (SizeOp op) = typeCheckSizeOp op
− src/Futhark/Representation/Kernels/KernelExp.hs
@@ -1,607 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}--- | A representation of nested-parallel in-kernel per-workgroup--- expressions.-module Futhark.Representation.Kernels.KernelExp- ( KernelExp(..)- , GroupStreamLambda(..)- , SplitOrdering(..)- , CombineSpace(..)- , combineSpace- , scopeOfCombineSpace- , typeCheckKernelExp- )- where--import Control.Monad-import Data.Monoid ((<>))-import Data.Maybe-import qualified Data.Map.Strict as M--import qualified Futhark.Analysis.Alias as Alias-import qualified Futhark.Analysis.Range as Range-import Futhark.Representation.Aliases-import Futhark.Representation.Ranges-import Futhark.Transform.Substitute-import Futhark.Transform.Rename-import Futhark.Optimise.Simplify.Lore-import Futhark.Analysis.Metrics-import qualified Futhark.Analysis.ScalExp as SE-import qualified Futhark.Analysis.SymbolTable as ST-import Futhark.Util.Pretty- ((<+>), (</>), ppr, comma, commasep, Pretty, parens, text, apply, braces, annot, indent)-import qualified Futhark.TypeCheck as TC-import Futhark.Util (chunks)---- | How an array is split into chunks.-data SplitOrdering = SplitContiguous- | SplitStrided SubExp- deriving (Eq, Ord, Show)---- | A combine can be fully or partially in-place. The initial arrays--- here work like the ones from the Scatter SOAC.-data CombineSpace = CombineSpace { cspaceScatter :: [(SubExp, Int, VName)]- , cspaceDims :: [(VName,SubExp)] }- deriving (Eq, Ord, Show)--combineSpace :: [(VName,SubExp)] -> CombineSpace-combineSpace = CombineSpace []--scopeOfCombineSpace :: CombineSpace -> Scope lore-scopeOfCombineSpace (CombineSpace _ dims) =- M.fromList $ zip (map fst dims) $ repeat $ IndexInfo Int32--data KernelExp lore = SplitSpace SplitOrdering SubExp SubExp SubExp- -- ^ @SplitSpace o w i elems_per_thread@.- --- -- Computes how to divide array elements to- -- threads in a kernel. Returns the number of- -- elements in the chunk that the current thread- -- should take.- --- -- @w@ is the length of the outer dimension in- -- the array. @i@ is the current thread- -- index. Each thread takes at most- -- @elems_per_thread@ elements.- --- -- If the order @o@ is 'SplitContiguous', thread with index @i@- -- should receive elements- -- @i*elems_per_tread, i*elems_per_thread + 1,- -- ..., i*elems_per_thread + (elems_per_thread-1)@.- --- -- If the order @o@ is @'SplitStrided' stride@,- -- the thread will receive elements @i,- -- i+stride, i+2*stride, ...,- -- i+(elems_per_thread-1)*stride@.- | Combine CombineSpace [Type] [(VName,SubExp)] (Body lore)- -- ^ @Combine cspace ts aspace body@ will- -- combine values from threads to a single- -- (multidimensional) array. If we define @(is,- -- ws) = unzip cspace@, then @ws@ is defined the- -- same accross all threads. The @cspace@- -- defines the shape of the resulting array, and- -- the identifiers used to identify each- -- individual element. Only threads for which- -- @all (\(i,w) -> i < w) aspace@ is true will- -- provide a value (of type @ts@), which is- -- generated by @body@.- --- -- The result of a combine is always stored in local- -- memory (OpenCL terminology)- --- -- The same thread may be assigned to multiple- -- elements of 'Combine', if the size of the- -- 'CombineSpace' exceeds the group size.- | GroupReduce SubExp- (Lambda lore) [(SubExp,VName)]- -- ^ @GroupReduce w lam input@ (with @(nes, arrs) = unzip input@),- -- will perform a reduction of the arrays @arrs@ using the- -- associative reduction operator @lam@ and the neutral- -- elements @nes@.- --- -- The arrays @arrs@ must all have outer- -- dimension @w@, which must not be larger than- -- the group size.- --- -- Currently a GroupReduce consumes the input arrays, as- -- it uses them for scratch space to store temporary- -- results- --- -- All threads in a group must participate in a- -- GroupReduce (due to barriers)- --- -- The length of the arrays @w@ can be smaller than the- -- number of elements in a group (neutral element will be- -- filled in), but @w@ can never be larger than the group- -- size.- | GroupScan SubExp- (Lambda lore) [(SubExp,VName)]- -- ^ Same restrictions as with 'GroupReduce'.- | GroupStream SubExp SubExp- (GroupStreamLambda lore) [SubExp] [VName]- -- Morally a StreamSeq- -- First SubExp is the outersize of the array- -- Second SubExp is the maximal chunk size- -- [SubExp] is the accumulator, [VName] are the input arrays- | GroupGenReduce [SubExp] [VName] (LambdaT lore) [SubExp] [SubExp] VName- -- ^ GroupGenReduce <length> <destarrays> <op> <bucket> <values> <locks arrays>- | Barrier [SubExp]- -- ^ HACK: Semantically identity, but inserts a- -- barrier afterwards. This reflects a weakness- -- in our kernel representation.- deriving (Eq, Ord, Show)--data GroupStreamLambda lore = GroupStreamLambda- { groupStreamChunkSize :: VName- , groupStreamChunkOffset :: VName- , groupStreamAccParams :: [LParam lore]- , groupStreamArrParams :: [LParam lore]- , groupStreamLambdaBody :: Body lore- }--deriving instance Annotations lore => Eq (GroupStreamLambda lore)-deriving instance Annotations lore => Show (GroupStreamLambda lore)-deriving instance Annotations lore => Ord (GroupStreamLambda lore)--instance Attributes lore => IsOp (KernelExp lore) where- safeOp _ = False- cheapOp _ = True--instance Attributes lore => TypedOp (KernelExp lore) where- opType SplitSpace{} =- pure $ staticShapes [Prim int32]- opType (Combine (CombineSpace scatter cspace) ts _ _) =- pure $ staticShapes $- zipWith arrayOfRow val_ts ws ++- map (`arrayOfShape` shape) (drop (sum ns*2) ts)- where shape = Shape $ map snd cspace- val_ts = concatMap (take 1) $ chunks ns $- take (sum ns) $ drop (sum ns) ts- (ws, ns, _) = unzip3 scatter- opType (GroupReduce _ lam _) =- pure $ staticShapes $ lambdaReturnType lam- opType (GroupScan w lam _) =- pure $ staticShapes $ map (`arrayOfRow` w) (lambdaReturnType lam)- opType (GroupStream _ _ lam _ _) =- pure $ staticShapes $ map paramType $ groupStreamAccParams lam- opType (GroupGenReduce _ dests _ _ _ _) =- staticShapes <$> traverse lookupType dests- opType (Barrier ses) = staticShapes <$> traverse subExpType ses--instance FreeIn SplitOrdering where- freeIn' SplitContiguous = mempty- freeIn' (SplitStrided stride) = freeIn' stride--instance Attributes lore => FreeIn (KernelExp lore) where- freeIn' (SplitSpace o w i elems_per_thread) =- freeIn' o <> freeIn' [w, i, elems_per_thread]- freeIn' (Combine (CombineSpace scatter cspace) ts active body) =- freeIn' scatter <> freeIn' (map snd cspace) <> freeIn' ts <> freeIn' active <> freeIn' body- freeIn' (GroupReduce w lam input) =- freeIn' w <> freeIn' lam <> freeIn' input- freeIn' (GroupScan w lam input) =- freeIn' w <> freeIn' lam <> freeIn' input- freeIn' (GroupStream w maxchunk lam accs arrs) =- freeIn' w <> freeIn' maxchunk <> freeIn' lam <> freeIn' accs <> freeIn' arrs- freeIn' (GroupGenReduce w dests op bucket values locks) =- freeIn' w <> freeIn' dests <> freeIn' op <> freeIn' bucket <> freeIn' values <> freeIn' locks- freeIn' (Barrier ses) = freeIn' ses--instance Attributes lore => FreeIn (GroupStreamLambda lore) where- freeIn' (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- fvBind bound_here $ freeIn' body- where bound_here = namesFromList $- chunk_offset : chunk_size :- map paramName (acc_params ++ arr_params)--instance Ranged inner => RangedOp (KernelExp inner) where- opRanges (SplitSpace _ _ _ elems_per_thread) =- [(Just (ScalarBound 0),- Just (ScalarBound (SE.subExpToScalExp elems_per_thread int32)))]- opRanges _ = repeat unknownRange--instance (Attributes lore, Aliased lore) => AliasedOp (KernelExp lore) where- opAliases SplitSpace{} =- [mempty]- opAliases Combine{} =- [mempty]- opAliases (GroupReduce _ lam _) =- replicate (length (lambdaReturnType lam)) mempty- opAliases (GroupScan _ lam _) =- replicate (length (lambdaReturnType lam)) mempty- opAliases (GroupStream _ _ lam _ _) =- map (const mempty) $ groupStreamAccParams lam- opAliases (GroupGenReduce _ dests _ _ _ _) =- map oneName dests- opAliases (Barrier ses) = map subExpAliases ses-- consumedInOp (GroupReduce _ _ input) =- namesFromList $ map snd input- consumedInOp (GroupScan _ _ input) =- namesFromList $ map snd input- consumedInOp (GroupStream _ _ lam accs arrs) =- -- GroupStream always consumes array-typed accumulators. This- -- guarantees that we can use their storage for the result of the- -- lambda.- namesFromList $ map consumedArray $- map paramName acc_params <> namesToList (consumedInBody body)- where GroupStreamLambda _ _ acc_params arr_params body = lam- consumedArray v = fromMaybe v $ subExpVar =<< lookup v params_to_arrs- params_to_arrs = zip (map paramName $ acc_params ++ arr_params) $- accs ++ map Var arrs- consumedInOp (GroupGenReduce _ dests _ _ _ _) =- namesFromList dests-- consumedInOp SplitSpace{} = mempty- consumedInOp Barrier{} = mempty- consumedInOp (Combine _ _ _ body) = consumedInBody body--instance Substitute SplitOrdering where- substituteNames _ SplitContiguous =- SplitContiguous- substituteNames subst (SplitStrided stride) =- SplitStrided $ substituteNames subst stride--instance Substitute CombineSpace where- substituteNames substs (CombineSpace scatter dims) =- CombineSpace (map sub scatter) (substituteNames substs dims)- where sub (w, n, a) =- (substituteNames substs w, n, substituteNames substs a)--instance Attributes lore => Substitute (KernelExp lore) where- substituteNames subst (SplitSpace o w i elems_per_thread) =- SplitSpace- (substituteNames subst o)- (substituteNames subst w)- (substituteNames subst i)- (substituteNames subst elems_per_thread)- substituteNames subst (Combine cspace ts active v) =- Combine (substituteNames subst cspace) ts- (substituteNames subst active) (substituteNames subst v)- substituteNames subst (GroupReduce w lam input) =- GroupReduce (substituteNames subst w)- (substituteNames subst lam) (substituteNames subst input)- substituteNames subst (GroupScan w lam input) =- GroupScan (substituteNames subst w)- (substituteNames subst lam) (substituteNames subst input)- substituteNames subst (GroupStream w maxchunk lam accs arrs) =- GroupStream- (substituteNames subst w) (substituteNames subst maxchunk)- (substituteNames subst lam)- (substituteNames subst accs) (substituteNames subst arrs)- substituteNames subst (GroupGenReduce w dests op bucket vs locks) =- GroupGenReduce (substituteNames subst w) (substituteNames subst dests)- (substituteNames subst op) (substituteNames subst bucket) (substituteNames subst vs)- (substituteNames subst locks)- substituteNames substs (Barrier ses) = Barrier $ substituteNames substs ses--instance Attributes lore => Substitute (GroupStreamLambda lore) where- substituteNames- subst (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- GroupStreamLambda- (substituteNames subst chunk_size)- (substituteNames subst chunk_offset)- (substituteNames subst acc_params)- (substituteNames subst arr_params)- (substituteNames subst body)--instance Rename SplitOrdering where- rename SplitContiguous =- pure SplitContiguous- rename (SplitStrided stride) =- SplitStrided <$> rename stride--instance Rename CombineSpace where- rename = substituteRename--instance Renameable lore => Rename (KernelExp lore) where- rename (SplitSpace o w i elems_per_thread) =- SplitSpace- <$> rename o- <*> rename w- <*> rename i- <*> rename elems_per_thread- rename (Combine cspace ts active v) =- Combine <$> rename cspace <*> rename ts <*> rename active <*> rename v- rename (GroupReduce w lam input) =- GroupReduce <$> rename w <*> rename lam <*> rename input- rename (GroupScan w lam input) =- GroupScan <$> rename w <*> rename lam <*> rename input- rename (GroupStream w maxchunk lam accs arrs) =- GroupStream <$> rename w <*> rename maxchunk <*>- rename lam <*> rename accs <*> rename arrs- rename (GroupGenReduce w dests op bucket vs locks) =- GroupGenReduce <$> rename w <*> rename dests <*> rename op <*>- rename bucket <*> rename vs <*> rename locks- rename (Barrier ses) = Barrier <$> mapM rename ses--instance Renameable lore => Rename (GroupStreamLambda lore) where- rename (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- bindingForRename (chunk_size : chunk_offset : map paramName (acc_params++arr_params)) $- GroupStreamLambda <$>- rename chunk_size <*>- rename chunk_offset <*>- rename acc_params <*>- rename arr_params <*>- rename body--instance (Attributes lore,- Attributes (Aliases lore),- CanBeAliased (Op lore)) => CanBeAliased (KernelExp lore) where- type OpWithAliases (KernelExp lore) = KernelExp (Aliases lore)-- addOpAliases (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread- addOpAliases (GroupReduce w lam input) =- GroupReduce w (Alias.analyseLambda lam) input- addOpAliases (GroupScan w lam input) =- GroupScan w (Alias.analyseLambda lam) input- addOpAliases (GroupStream w maxchunk lam accs arrs) =- GroupStream w maxchunk lam' accs arrs- where lam' = analyseGroupStreamLambda lam- analyseGroupStreamLambda (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- GroupStreamLambda chunk_size chunk_offset acc_params arr_params $- Alias.analyseBody body- addOpAliases (GroupGenReduce w dests op bucket vs locks) =- GroupGenReduce w dests (Alias.analyseLambda op) bucket vs locks- addOpAliases (Combine cspace ts active body) =- Combine cspace ts active $ Alias.analyseBody body- addOpAliases (Barrier ses) = Barrier ses-- removeOpAliases (GroupReduce w lam input) =- GroupReduce w (removeLambdaAliases lam) input- removeOpAliases (GroupScan w lam input) =- GroupScan w (removeLambdaAliases lam) input- removeOpAliases (GroupStream w maxchunk lam accs arrs) =- GroupStream w maxchunk (removeGroupStreamLambdaAliases lam) accs arrs- where removeGroupStreamLambdaAliases (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- GroupStreamLambda chunk_size chunk_offset acc_params arr_params $- removeBodyAliases body- removeOpAliases (GroupGenReduce w dests op bucket vs locks) =- GroupGenReduce w dests (removeLambdaAliases op) bucket vs locks- removeOpAliases (Combine cspace ts active body) =- Combine cspace ts active $ removeBodyAliases body- removeOpAliases (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread- removeOpAliases (Barrier ses) = Barrier ses--instance (Attributes lore,- Attributes (Ranges lore),- CanBeRanged (Op lore)) => CanBeRanged (KernelExp lore) where- type OpWithRanges (KernelExp lore) = KernelExp (Ranges lore)-- addOpRanges (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread- addOpRanges (GroupReduce w lam input) =- GroupReduce w (Range.runRangeM $ Range.analyseLambda lam) input- addOpRanges (GroupScan w lam input) =- GroupScan w (Range.runRangeM $ Range.analyseLambda lam) input- addOpRanges (GroupGenReduce w dests op bucket vs locks) =- GroupGenReduce w dests (Range.runRangeM $ Range.analyseLambda op) bucket vs locks- addOpRanges (Combine cspace ts active body) =- Combine cspace ts active $ Range.runRangeM $ Range.analyseBody body- addOpRanges (GroupStream w maxchunk lam accs arrs) =- GroupStream w maxchunk lam' accs arrs- where lam' = analyseGroupStreamLambda lam- analyseGroupStreamLambda (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- GroupStreamLambda chunk_size chunk_offset acc_params arr_params $- Range.runRangeM $ Range.analyseBody body- addOpRanges (Barrier ses) = Barrier ses-- removeOpRanges (GroupReduce w lam input) =- GroupReduce w (removeLambdaRanges lam) input- removeOpRanges (GroupScan w lam input) =- GroupScan w (removeLambdaRanges lam) input- removeOpRanges (GroupStream w maxchunk lam accs arrs) =- GroupStream w maxchunk (removeGroupStreamLambdaRanges lam) accs arrs- where removeGroupStreamLambdaRanges (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- GroupStreamLambda chunk_size chunk_offset acc_params arr_params $- removeBodyRanges body- removeOpRanges (GroupGenReduce w dests op bucket vs locks) =- GroupGenReduce w dests (removeLambdaRanges op) bucket vs locks- removeOpRanges (Combine cspace ts active body) =- Combine cspace ts active $ removeBodyRanges body- removeOpRanges (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread- removeOpRanges (Barrier ses) = Barrier ses--instance (Attributes lore, CanBeWise (Op lore)) => CanBeWise (KernelExp lore) where- type OpWithWisdom (KernelExp lore) = KernelExp (Wise lore)-- removeOpWisdom (GroupReduce w lam input) =- GroupReduce w (removeLambdaWisdom lam) input- removeOpWisdom (GroupScan w lam input) =- GroupScan w (removeLambdaWisdom lam) input- removeOpWisdom (GroupStream w maxchunk lam accs arrs) =- GroupStream w maxchunk (removeGroupStreamLambdaWisdom lam) accs arrs- where removeGroupStreamLambdaWisdom- (GroupStreamLambda chunk_size chunk_offset acc_params arr_params body) =- GroupStreamLambda chunk_size chunk_offset acc_params arr_params $- removeBodyWisdom body- removeOpWisdom (GroupGenReduce w dests op bucket vs locks) =- GroupGenReduce w dests (removeLambdaWisdom op) bucket vs locks- removeOpWisdom (Combine cspace ts active body) =- Combine cspace ts active $ removeBodyWisdom body- removeOpWisdom (SplitSpace o w i elems_per_thread) =- SplitSpace o w i elems_per_thread- removeOpWisdom (Barrier ses) = Barrier ses--instance ST.IndexOp (KernelExp lore) where--instance OpMetrics (Op lore) => OpMetrics (KernelExp lore) where- opMetrics SplitSpace{} = seen "SplitSpace"- opMetrics Combine{} = seen "Combine"- opMetrics (GroupReduce _ lam _) = inside "GroupReduce" $ lambdaMetrics lam- opMetrics (GroupScan _ lam _) = inside "GroupScan" $ lambdaMetrics lam- opMetrics (GroupGenReduce _ _ op _ _ _) = inside "GroupGenReduce" $ lambdaMetrics op- opMetrics (GroupStream _ _ lam _ _) =- inside "GroupStream" $ groupStreamLambdaMetrics lam- where groupStreamLambdaMetrics =- bodyMetrics . groupStreamLambdaBody- opMetrics Barrier{} = seen "Barrier"--typeCheckKernelExp :: TC.Checkable lore => KernelExp (Aliases lore) -> TC.TypeM lore ()--typeCheckKernelExp Barrier{} = return ()--typeCheckKernelExp (SplitSpace o w i elems_per_thread) = do- case o of- SplitContiguous -> return ()- SplitStrided stride -> TC.require [Prim int32] stride- mapM_ (TC.require [Prim int32]) [w, i, elems_per_thread]--typeCheckKernelExp (Combine cspace@(CombineSpace scatter dims) ts aspace body) = do- mapM_ (TC.require [Prim int32]) ws- TC.binding (scopeOfCombineSpace cspace) $ do- let (_as_ws, as_ns, _as_vs) = unzip3 scatter- num_scatters = sum as_ns- ts_is = take num_scatters ts- ts_vs = take num_scatters $ drop num_scatters ts-- unless (length ts_is == num_scatters && length ts_vs == num_scatters) $- TC.bad $ TC.TypeError "Combine: inconsistent return type annotation."-- forM_ ts_is $ \ts_i -> unless (Prim int32 == ts_i) $- TC.bad $ TC.TypeError "Combine: index return type must be i32."-- to_consume <- forM (zip (chunks as_ns ts_vs) scatter) $ \(ts_vs', (aw, _, a)) -> do- TC.require [Prim int32] aw- forM_ ts_vs' $ \ts_v -> TC.requireI [ts_v `arrayOfRow` aw] a- return a- -- Consume all at once because it is valid to do two scatters to the same array.- TC.consume . mconcat =<< mapM TC.lookupAliases to_consume-- mapM_ TC.checkType ts- mapM_ (TC.requireI [Prim int32]) a_is- mapM_ (TC.require [Prim int32]) a_ws- TC.checkLambdaBody ts body- where ws = map snd dims- (a_is, a_ws) = unzip aspace--typeCheckKernelExp (GroupReduce w lam input) =- checkScanOrReduce w lam input--typeCheckKernelExp (GroupScan w lam input) =- checkScanOrReduce w lam input--typeCheckKernelExp (GroupGenReduce ws dests op bucket vs locks) = do- mapM_ (TC.require [Prim int32]) ws-- mapM_ (TC.require [Prim int32]) bucket-- dest_row_ts <- mapM (fmap (stripArray (length bucket)) . lookupType) dests-- vs_ts <- mapM subExpType vs- unless (vs_ts == dest_row_ts) $- TC.bad $ TC.TypeError $ "Destination arrays have type " ++- pretty dest_row_ts ++ ", but values to write have type " ++ pretty vs_ts-- TC.requireI [Prim int32 `arrayOfShape` Shape ws] locks-- let asArg t = (t, mempty)- TC.checkLambda op $ map asArg $ dest_row_ts ++ vs_ts--typeCheckKernelExp (GroupStream w maxchunk lam accs arrs) = do- TC.require [Prim int32] w- TC.require [Prim int32] maxchunk-- acc_args <- mapM TC.checkArg accs- arr_args <- TC.checkSOACArrayArgs w arrs-- checkGroupStreamLambda acc_args arr_args- where GroupStreamLambda block_size _ acc_params arr_params body = lam- checkGroupStreamLambda acc_args arr_args = do- unless (map TC.argType acc_args == map paramType acc_params) $- TC.bad $ TC.TypeError- "checkGroupStreamLambda: wrong accumulator arguments."-- let arr_block_ts =- map ((`arrayOfRow` Var block_size) . TC.argType) arr_args- unless (map paramType arr_params == arr_block_ts) $- TC.bad $ TC.TypeError- "checkGroupStreamLambda: wrong array arguments."-- let acc_consumable =- zip (map paramName acc_params) (map TC.argAliases acc_args)- arr_consumable =- zip (map paramName arr_params) (map TC.argAliases arr_args)- consumable = acc_consumable ++ arr_consumable- TC.binding (scopeOf lam) $ TC.consumeOnlyParams consumable $ do- TC.checkLambdaParams acc_params- TC.checkLambdaParams arr_params- TC.checkLambdaBody (map TC.argType acc_args) body--checkScanOrReduce :: TC.Checkable lore =>- SubExp -> Lambda (Aliases lore) -> [(SubExp, VName)]- -> TC.TypeM lore ()-checkScanOrReduce w lam input = do- TC.require [Prim int32] w- let (nes, arrs) = unzip input- neargs <- mapM TC.checkArg nes- arrargs <- TC.checkSOACArrayArgs w arrs- TC.checkLambda lam $ map TC.noArgAliases (neargs ++ arrargs)--instance Scoped lore (GroupStreamLambda lore) where- scopeOf (GroupStreamLambda chunk_size chunk_offset acc_params arr_params _) =- M.insert chunk_size (IndexInfo Int32) $- M.insert chunk_offset (IndexInfo Int32) $- scopeOfLParams (acc_params ++ arr_params)--instance PrettyLore lore => Pretty (KernelExp lore) where- ppr (SplitSpace o w i elems_per_thread) =- text "splitSpace" <> suff <>- parens (commasep [ppr w, ppr i, ppr elems_per_thread])- where suff = case o of SplitContiguous -> mempty- SplitStrided stride -> text "Strided" <> parens (ppr stride)- ppr (Combine (CombineSpace scatter cspace) ts active body) =- text "combine" <>- apply (map (\(_,n,a) -> text "@" <> ppr (n,a)) scatter ++- map (\(i,w) -> ppr i <+> text "<" <+> ppr w) cspace ++- [apply (map ppr ts), ppr active]) <+> text "{" </>- indent 2 (ppr body) </>- text "}"- ppr (GroupReduce w lam input) =- text "reduce" <> parens (commasep [ppr w,- ppr lam,- braces (commasep $ map ppr nes),- commasep $ map ppr els])- where (nes,els) = unzip input- ppr (GroupScan w lam input) =- text "scan" <> parens (commasep [ppr w,- ppr lam,- braces (commasep $ map ppr nes),- commasep $ map ppr els])- where (nes,els) = unzip input- ppr (GroupStream w maxchunk lam accs arrs) =- text "stream" <>- parens (ppr w <> comma <+> ppr maxchunk <> comma </>- ppr lam <> comma </>- braces (commasep $ map ppr accs) <> comma </>- commasep (map ppr arrs))-- ppr (GroupGenReduce w dests op bucket vs locks) =- text "gen_reduce" <>- parens (ppr w <> comma </>- braces (commasep $ map ppr dests) <> comma </>- ppr op <> comma </>- braces (commasep $ map ppr bucket) <> comma </>- braces (commasep $ map ppr vs) <> comma </>- ppr locks)-- ppr (Barrier ses) = text "barrier" <> parens (commasep $ map ppr ses)--instance PrettyLore lore => Pretty (GroupStreamLambda lore) where- ppr (GroupStreamLambda block_size block_offset acc_params arr_params body) =- annot (mapMaybe ppAnnot params) $- text "fn" <+>- parens (commasep (block_size' : block_offset' : map ppr params)) <+>- text "=>" </> indent 2 (ppr body)- where params = acc_params ++ arr_params- block_size' = text "int" <+> ppr block_size- block_offset' = text "int" <+> ppr block_offset
src/Futhark/Representation/Kernels/Simplify.hs view
@@ -87,12 +87,13 @@ return (SegOp $ SegScan lvl' space' scan_op' nes' ts' kbody', hoisted) -simplifyKernelOp _ (SegOp (SegGenRed lvl space ops ts kbody)) = do+simplifyKernelOp _ (SegOp (SegHist lvl space ops ts kbody)) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts) (ops', ops_hoisted) <- fmap unzip $ forM ops $- \(GenReduceOp w arrs nes dims lam) -> do+ \(HistOp w rf arrs nes dims lam) -> do w' <- Engine.simplify w+ rf' <- Engine.simplify rf arrs' <- Engine.simplify arrs nes' <- Engine.simplify nes dims' <- Engine.simplify dims@@ -100,28 +101,32 @@ Engine.localVtable (<>scope_vtable) $ Engine.simplifyLambda lam $ replicate (length nes * 2) Nothing- return (GenReduceOp w' arrs' nes' dims' lam',+ return (HistOp w' rf' arrs' nes' dims' lam', op_hoisted) (kbody', body_hoisted) <- simplifyKernelBody space kbody - return (SegOp $ SegGenRed lvl' space' ops' ts' kbody',+ return (SegOp $ SegHist lvl' space' ops' ts' kbody', mconcat ops_hoisted <> body_hoisted) where scope = scopeOfSegSpace space scope_vtable = ST.fromScope scope -simplifyKernelOp _ (SplitSpace o w i elems_per_thread) =- (,) <$> (SplitSpace <$> Engine.simplify o <*> Engine.simplify w- <*> Engine.simplify i <*> Engine.simplify elems_per_thread)+simplifyKernelOp _ (SizeOp (SplitSpace o w i elems_per_thread)) =+ (,) <$> (SizeOp <$>+ (SplitSpace <$> Engine.simplify o <*> Engine.simplify w+ <*> Engine.simplify i <*> Engine.simplify elems_per_thread)) <*> pure mempty-simplifyKernelOp _ (GetSize key size_class) =- return (GetSize key size_class, mempty)-simplifyKernelOp _ (GetSizeMax size_class) =- return (GetSizeMax size_class, mempty)-simplifyKernelOp _ (CmpSizeLe key size_class x) = do+simplifyKernelOp _ (SizeOp (GetSize key size_class)) =+ return (SizeOp $ GetSize key size_class, mempty)+simplifyKernelOp _ (SizeOp (GetSizeMax size_class)) =+ return (SizeOp $ GetSizeMax size_class, mempty)+simplifyKernelOp _ (SizeOp (CmpSizeLe key size_class x)) = do x' <- Engine.simplify x- return (CmpSizeLe key size_class x', mempty)+ return (SizeOp $ CmpSizeLe key size_class x', mempty)+simplifyKernelOp _ (SizeOp (CalcNumGroups w max_num_groups group_size)) = do+ w' <- Engine.simplify w+ return (SizeOp $ CalcNumGroups w' max_num_groups group_size, mempty) simplifyRedOrScan :: (Engine.SimplifiableLore lore, BodyAttr lore ~ ()) => SegSpace
src/Futhark/Representation/Primitive.hs view
@@ -81,6 +81,7 @@ import Control.Applicative import Data.Binary.IEEE754 (floatToWord, wordToFloat, doubleToWord, wordToDouble) import Data.Bits+import Data.Fixed (mod') -- Weird location. import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.Map as M import Data.Word@@ -88,7 +89,9 @@ import Prelude import Futhark.Util.Pretty-import Futhark.Util (roundFloat, roundDouble, lgamma, lgammaf, tgamma, tgammaf)+import Futhark.Util (roundFloat, ceilFloat, floorFloat,+ roundDouble, ceilDouble, floorDouble,+ lgamma, lgammaf, tgamma, tgammaf) -- | An integer type, ordered by size. Note that signedness is not a -- property of the type, but a property of the operations performed on@@ -290,6 +293,7 @@ -- negativity infinity. Note: this is different -- from LLVM. | FDiv FloatType -- ^ Floating-point division.+ | FMod FloatType -- ^ Floating-point modulus. | UMod IntType -- ^ Unsigned integer modulus; the countepart to 'UDiv'.@@ -401,6 +405,7 @@ , map UDiv allIntTypes , map SDiv allIntTypes , map FDiv allFloatTypes+ , map FMod allFloatTypes , map UMod allIntTypes , map SMod allIntTypes , map SQuot allIntTypes@@ -485,6 +490,7 @@ doBinOp UDiv{} = doRiskyIntBinOp doUDiv doBinOp SDiv{} = doRiskyIntBinOp doSDiv doBinOp FDiv{} = doFloatBinOp (/) (/)+doBinOp FMod{} = doFloatBinOp mod' mod' doBinOp UMod{} = doRiskyIntBinOp doUMod doBinOp SMod{} = doRiskyIntBinOp doSMod doBinOp SQuot{} = doRiskyIntBinOp doSQuot@@ -782,6 +788,7 @@ binOpType (FSub t) = FloatType t binOpType (FMul t) = FloatType t binOpType (FDiv t) = FloatType t+binOpType (FMod t) = FloatType t -- | The operand types of a comparison operator. cmpOpType :: CmpOp -> PrimType@@ -833,6 +840,8 @@ , f32 "acos32" acos, f64 "acos64" acos , f32 "atan32" atan, f64 "atan64" atan , f32 "round32" roundFloat, f64 "round64" roundDouble+ , f32 "ceil32" ceilFloat, f64 "ceil64" ceilDouble+ , f32 "floor32" floorFloat, f64 "floor64" floorDouble , f32 "gamma32" tgammaf, f64 "gamma64" tgamma , f32 "lgamma32" lgammaf, f64 "lgamma64" lgamma @@ -896,6 +905,25 @@ [IntValue (Int64Value x)] -> Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x _ -> Nothing))++ , ("lerp32",+ ([FloatType Float32, FloatType Float32, FloatType Float32], FloatType Float32,+ \case+ [FloatValue (Float32Value v0),+ FloatValue (Float32Value v1),+ FloatValue (Float32Value t)] ->+ Just $ FloatValue $ Float32Value $+ v0 + (v1-v0)*max 0 (min 1 t)+ _ -> Nothing))+ , ("lerp64",+ ([FloatType Float64, FloatType Float64, FloatType Float64], FloatType Float64,+ \case+ [FloatValue (Float64Value v0),+ FloatValue (Float64Value v1),+ FloatValue (Float64Value t)] ->+ Just $ FloatValue $ Float64Value $+ v0 + (v1-v0)*max 0 (min 1 t)+ _ -> Nothing)) ] where f32 s f = (s, ([FloatType Float32], FloatType Float32, f32PrimFun f)) f64 s f = (s, ([FloatType Float64], FloatType Float64, f64PrimFun f))@@ -1007,6 +1035,7 @@ ppr (SQuot t) = taggedI "squot" t ppr (SRem t) = taggedI "srem" t ppr (FDiv t) = taggedF "fdiv" t+ ppr (FMod t) = taggedF "fmod" t ppr (SMin t) = taggedI "smin" t ppr (UMin t) = taggedI "umin" t ppr (FMin t) = taggedF "fmin" t
src/Futhark/Representation/Ranges.hs view
@@ -34,7 +34,6 @@ import Control.Monad.Identity import Control.Monad.Reader-import Data.Monoid ((<>)) import Data.Foldable import Futhark.Representation.AST.Syntax
src/Futhark/Representation/SOACS/SOAC.hs view
@@ -8,7 +8,7 @@ ( SOAC(..) , StreamForm(..) , ScremaForm(..)- , GenReduceOp(..)+ , HistOp(..) , Scan , Reduce(..) , redResults@@ -38,7 +38,7 @@ , isMapSOAC , ppScrema- , ppGenReduce+ , ppHist -- * Generic traversal , SOACMapper(..)@@ -57,7 +57,7 @@ import Futhark.Representation.AST import qualified Futhark.Analysis.Alias as Alias import qualified Futhark.Util.Pretty as PP-import Futhark.Util.Pretty (ppr, Doc, Pretty, parens, comma, (</>), commasep, text)+import Futhark.Util.Pretty (ppr, Doc, Pretty, parens, comma, (</>), (<+>), commasep, text) import Futhark.Representation.AST.Attributes.Aliases import Futhark.Transform.Substitute import Futhark.Transform.Rename@@ -91,8 +91,8 @@ -- [index_0, index_1, ..., index_n, value_0, value_1, ..., value_n] -- -- This must be consistent along all Scatter-related optimisations.- | GenReduce SubExp [GenReduceOp lore] (Lambda lore) [VName]- -- GenReduce <length> <dest-arrays-and-ops> <bucket fun> <input arrays>+ | Hist SubExp [HistOp lore] (Lambda lore) [VName]+ -- Hist <length> <dest-arrays-and-ops> <bucket fun> <input arrays> -- -- The first SubExp is the length of the input arrays. The first -- list describes the operations to perform. The 'Lambda' is the@@ -106,11 +106,14 @@ | CmpThreshold SubExp String deriving (Eq, Ord, Show) -data GenReduceOp lore = GenReduceOp { genReduceWidth :: SubExp- , genReduceDest :: [VName]- , genReduceNeutral :: [SubExp]- , genReduceOp :: Lambda lore- }+data HistOp lore = HistOp { histWidth :: SubExp+ , histRaceFactor :: SubExp+ -- ^ Race factor @RF@ means that only @1/RF@+ -- bins are used.+ , histDest :: [VName]+ , histNeutral :: [SubExp]+ , histOp :: Lambda lore+ } deriving (Eq, Ord, Show) data StreamForm lore =@@ -296,11 +299,12 @@ <*> mapM (mapOnSOACVName tv) ivs <*> mapM (\(aw,an,a) -> (,,) <$> mapOnSOACSubExp tv aw <*> pure an <*> mapOnSOACVName tv a) as-mapSOACM tv (GenReduce len ops bucket_fun imgs) =- GenReduce+mapSOACM tv (Hist len ops bucket_fun imgs) =+ Hist <$> mapOnSOACSubExp tv len- <*> mapM (\(GenReduceOp e arrs nes op) ->- GenReduceOp <$> mapOnSOACSubExp tv e+ <*> mapM (\(HistOp e rf arrs nes op) ->+ HistOp <$> mapOnSOACSubExp tv e+ <*> mapOnSOACSubExp tv rf <*> mapM (mapOnSOACVName tv) arrs <*> mapM (mapOnSOACSubExp tv) nes <*> mapOnSOACLambda tv op) ops@@ -352,9 +356,9 @@ where val_ts = concatMap (take 1) $ chunks ns $ drop (sum ns) $ lambdaReturnType lam (ws, ns, _) = unzip3 as-soacType (GenReduce _len ops _bucket_fun _imgs) = do+soacType (Hist _len ops _bucket_fun _imgs) = do op <- ops- map (`arrayOfRow` genReduceWidth op) (lambdaReturnType $ genReduceOp op)+ map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op) soacType (Screma w form _arrs) = scremaType w form soacType CmpThreshold{} = [Prim Bool]@@ -384,14 +388,14 @@ (accs++map Var arrs) consumedInOp (Scatter _ _ _ as) = namesFromList $ map (\(_, _, a) -> a) as- consumedInOp (GenReduce _ ops _ _) =- namesFromList $ concatMap genReduceDest ops+ consumedInOp (Hist _ ops _ _) =+ namesFromList $ concatMap histDest ops consumedInOp CmpThreshold{} = mempty -mapGenReduceOp :: (Lambda flore -> Lambda tlore)- -> GenReduceOp flore -> GenReduceOp tlore-mapGenReduceOp f (GenReduceOp w dests nes lam) =- GenReduceOp w dests nes $ f lam+mapHistOp :: (Lambda flore -> Lambda tlore)+ -> HistOp flore -> HistOp tlore+mapHistOp f (HistOp w rf dests nes lam) =+ HistOp w rf dests nes $ f lam instance (Attributes lore, Attributes (Aliases lore),@@ -406,8 +410,8 @@ analyseStreamForm (Sequential acc) = Sequential acc addOpAliases (Scatter len lam ivs as) = Scatter len (Alias.analyseLambda lam) ivs as- addOpAliases (GenReduce len ops bucket_fun imgs) =- GenReduce len (map (mapGenReduceOp Alias.analyseLambda) ops)+ addOpAliases (Hist len ops bucket_fun imgs) =+ Hist len (map (mapHistOp Alias.analyseLambda) ops) (Alias.analyseLambda bucket_fun) imgs addOpAliases (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) = Screma w (ScremaForm@@ -458,8 +462,8 @@ return $ Parallel o comm lam0' acc addOpRanges (Scatter len lam ivs as) = Scatter len (Range.runRangeM $ Range.analyseLambda lam) ivs as- addOpRanges (GenReduce len ops bucket_fun imgs) =- GenReduce len (map (mapGenReduceOp $ Range.runRangeM . Range.analyseLambda) ops)+ addOpRanges (Hist len ops bucket_fun imgs) =+ Hist len (map (mapHistOp $ Range.runRangeM . Range.analyseLambda) ops) (Range.runRangeM $ Range.analyseLambda bucket_fun) imgs addOpRanges (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) = Screma w (ScremaForm@@ -600,13 +604,14 @@ arrargs <- TC.checkSOACArrayArgs w ivs TC.checkLambda lam arrargs -typeCheckSOAC (GenReduce len ops bucket_fun imgs) = do+typeCheckSOAC (Hist len ops bucket_fun imgs) = do TC.require [Prim int32] len -- Check the operators.- forM_ ops $ \(GenReduceOp dest_w dests nes op) -> do+ forM_ ops $ \(HistOp dest_w rf dests nes op) -> do nes' <- mapM TC.checkArg nes TC.require [Prim int32] dest_w+ TC.require [Prim int32] rf -- Operator type must match the type of neutral elements. TC.checkLambda op $ map TC.noArgAliases $ nes' ++ nes'@@ -627,7 +632,7 @@ -- Return type of bucket function must be an index for each -- operation followed by the values to write.- nes_ts <- concat <$> mapM (mapM subExpType . genReduceNeutral) ops+ nes_ts <- concat <$> mapM (mapM subExpType . histNeutral) ops let bucket_ret_t = replicate (length ops) (Prim int32) ++ nes_ts unless (bucket_ret_t == lambdaReturnType bucket_fun) $ TC.bad $ TC.TypeError $ "Bucket function has return type " ++@@ -678,8 +683,8 @@ inside "Stream" $ lambdaMetrics lam opMetrics (Scatter _len lam _ivs _as) = inside "Scatter" $ lambdaMetrics lam- opMetrics (GenReduce _len ops bucket_fun _imgs) =- inside "GenReduce" $ mapM_ (lambdaMetrics . genReduceOp) ops >> lambdaMetrics bucket_fun+ opMetrics (Hist _len ops bucket_fun _imgs) =+ inside "Hist" $ mapM_ (lambdaMetrics . histOp) ops >> lambdaMetrics bucket_fun opMetrics (Screma _ (ScremaForm (scan_lam, _) reds map_lam) _) = inside "Screma" $ do lambdaMetrics scan_lam mapM_ (lambdaMetrics . redLambda) reds@@ -702,8 +707,8 @@ commasep ( PP.braces (commasep $ map ppr acc) : map ppr arrs )) ppr (Scatter len lam ivs as) = ppSOAC "scatter" len [lam] (Just (map Var ivs)) (map (\(_,n,a) -> (n,a)) as)- ppr (GenReduce len ops bucket_fun imgs) =- ppGenReduce len ops bucket_fun imgs+ ppr (Hist len ops bucket_fun imgs) =+ ppHist len ops bucket_fun imgs ppr (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) | isNilFn scan_lam, null scan_nes, null reds = text "map" <>@@ -749,16 +754,16 @@ ppComm comm <> ppr red_lam <> comma </> PP.braces (commasep $ map ppr red_nes) -ppGenReduce :: (PrettyLore lore, Pretty inp) =>- SubExp -> [GenReduceOp lore] -> Lambda lore -> [inp] -> Doc-ppGenReduce len ops bucket_fun imgs =- text "gen_reduce" <>+ppHist :: (PrettyLore lore, Pretty inp) =>+ SubExp -> [HistOp lore] -> Lambda lore -> [inp] -> Doc+ppHist len ops bucket_fun imgs =+ text "hist" <> parens (ppr len <> comma </> PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppOp ops) <> comma </> ppr bucket_fun <> comma </> commasep (map ppr imgs))- where ppOp (GenReduceOp w dests nes op) =- ppr w <> comma <> PP.braces (commasep $ map ppr dests) <> comma </>+ where ppOp (HistOp w rf dests nes op) =+ ppr w <> comma <+> ppr rf <> comma <+> PP.braces (commasep $ map ppr dests) <> comma </> PP.braces (commasep $ map ppr nes) <> comma </> ppr op ppSOAC :: (Pretty fn, Pretty v) =>
src/Futhark/Representation/SOACS/Simplify.hs view
@@ -103,17 +103,18 @@ as' <- mapM Engine.simplify as return (Scatter len' lam' ivs' as', hoisted) -simplifySOAC (GenReduce w ops bfun imgs) = do+simplifySOAC (Hist w ops bfun imgs) = do w' <- Engine.simplify w- (ops', hoisted) <- fmap unzip $ forM ops $ \(GenReduceOp dests_w dests nes op) -> do+ (ops', hoisted) <- fmap unzip $ forM ops $ \(HistOp dests_w rf dests nes op) -> do dests_w' <- Engine.simplify dests_w+ rf' <- Engine.simplify rf dests' <- Engine.simplify dests nes' <- mapM Engine.simplify nes (op', hoisted) <- Engine.simplifyLambda op $ replicate (length $ lambdaParams op) Nothing- return (GenReduceOp dests_w' dests' nes' op', hoisted)+ return (HistOp dests_w' rf' dests' nes' op', hoisted) imgs' <- mapM Engine.simplify imgs (bfun', bfun_hoisted) <- Engine.simplifyLambda bfun $ map Just imgs- return (GenReduce w' ops' bfun' imgs', mconcat hoisted <> bfun_hoisted)+ return (Hist w' ops' bfun' imgs', mconcat hoisted <> bfun_hoisted) simplifySOAC (Screma w (ScremaForm (scan_lam, scan_nes) reds map_lam) arrs) = do (scan_lam', scan_lam_hoisted) <-
src/Futhark/Test.hs view
@@ -18,6 +18,7 @@ , runProgram , ensureReferenceOutput , determineTuning+ , binaryName , Mismatch , ProgramTest (..)@@ -46,7 +47,6 @@ import Data.Char import Data.Functor import Data.Maybe-import Data.Foldable (foldl') import Data.List import qualified Data.Text as T import qualified Data.Text.IO as T@@ -462,7 +462,7 @@ getValues dir v = do s <- getValuesBS dir v case valuesFromByteString file s of- Left e -> fail $ show e+ Left e -> error $ show e Right vs -> return vs where file = case v of Values{} -> "<values>" InFile f -> f@@ -573,6 +573,11 @@ RunTimeFailure err -> return $ RunTimeFailure err ++-- | The name we use for compiled programs.+binaryName :: FilePath -> FilePath+binaryName = dropExtension+ compileProgram :: (MonadIO m, MonadError [T.Text] m) => [String] -> FilePath -> String -> FilePath -> m (SBS.ByteString, SBS.ByteString)@@ -583,7 +588,7 @@ ExitFailure _ -> throwError [T.decodeUtf8 stderr] ExitSuccess -> return () return (stdout, stderr)- where binOutputf = dropExtension program+ where binOutputf = binaryName program options = [program, "-o", binOutputf] ++ extra_options progNotFound s = s <> ": command not found" @@ -592,7 +597,7 @@ -> String -> T.Text -> Values -> m (ExitCode, SBS.ByteString, SBS.ByteString) runProgram runner extra_options prog entry input = do- let progbin = dropExtension prog+ let progbin = binaryName prog dir = takeDirectory prog binpath = "." </> progbin entry_options = ["-e", T.unpack entry]
src/Futhark/Transform/FirstOrderTransform.hs view
@@ -70,7 +70,7 @@ , mapOnBranchType = return , mapOnFParam = return , mapOnLParam = return- , mapOnOp = fail "Unhandled Op in first order transform"+ , mapOnOp = error "Unhandled Op in first order transform" } -- | Transform a single 'SOAC' into a do-loop. The body of the lambda@@ -190,13 +190,13 @@ return $ resultBody (map Var ress) letBind_ pat $ DoLoop [] merge (ForLoop iter Int32 len []) loopBody -transformSOAC pat (GenReduce len ops bucket_fun imgs) = do+transformSOAC pat (Hist len ops bucket_fun imgs) = do iter <- newVName "iter" -- Bind arguments to parameters for the merge-variables.- hists_ts <- mapM lookupType $ concatMap genReduceDest ops+ hists_ts <- mapM lookupType $ concatMap histDest ops hists_out <- mapM (newIdent "dests") hists_ts- let merge = loopMerge hists_out $ concatMap (map Var . genReduceDest) ops+ let merge = loopMerge hists_out $ concatMap (map Var . histDest) ops -- Bind lambda-bodies for operators. loopBody <- runBodyBinder $@@ -212,8 +212,8 @@ -- Split out values from bucket function. let lens = length ops inds = take lens imgs''- vals = chunks (map (length . lambdaReturnType . genReduceOp) ops) $ drop lens imgs''- hists_out' = chunks (map (length . lambdaReturnType . genReduceOp) ops) $+ vals = chunks (map (length . lambdaReturnType . histOp) ops) $ drop lens imgs''+ hists_out' = chunks (map (length . lambdaReturnType . histOp) ops) $ map identName hists_out hists_out'' <- forM (zip4 hists_out' ops inds vals) $ \(hist, op, idx, val) -> do@@ -231,7 +231,7 @@ letSubExp "read_hist" $ BasicOp $ Index arr $ fullSlice arr_t [DimFix idx] -- Apply operator.- h_val' <- bindLambda (genReduceOp op) $+ h_val' <- bindLambda (histOp op) $ map (BasicOp . SubExp) $ h_val ++ val -- Write values back to histograms.
src/Futhark/Util.hs view
@@ -24,8 +24,8 @@ isEnvVarSet, runProgramWithExitCode, directoryContents,- roundFloat,- roundDouble,+ roundFloat, ceilFloat, floorFloat,+ roundDouble, ceilDouble, floorDouble, lgamma, lgammaf, tgamma, tgammaf, fromPOSIX, toPOSIX,@@ -176,14 +176,34 @@ foreign import ccall "nearbyint" c_nearbyint :: Double -> Double foreign import ccall "nearbyintf" c_nearbyintf :: Float -> Float+foreign import ccall "ceil" c_ceil :: Double -> Double+foreign import ccall "ceilf" c_ceilf :: Float -> Float+foreign import ccall "floor" c_floor :: Double -> Double+foreign import ccall "floorf" c_floorf :: Float -> Float -- | Round a single-precision floating point number correctly. roundFloat :: Float -> Float roundFloat = c_nearbyintf +-- | Round a single-precision floating point number upwards correctly.+ceilFloat :: Float -> Float+ceilFloat = c_ceilf++-- | Round a single-precision floating point number downwards correctly.+floorFloat :: Float -> Float+floorFloat = c_floorf+ -- | Round a double-precision floating point number correctly. roundDouble :: Double -> Double roundDouble = c_nearbyint++-- | Round a double-precision floating point number upwards correctly.+ceilDouble :: Double -> Double+ceilDouble = c_ceil++-- | Round a double-precision floating point number downwards correctly.+floorDouble :: Double -> Double+floorDouble = c_floor foreign import ccall "lgamma" c_lgamma :: Double -> Double foreign import ccall "lgammaf" c_lgammaf :: Float -> Float
src/Language/Futhark/Attributes.hs view
@@ -69,6 +69,7 @@ , isTypeParam , combineTypeShapes , unscopeType+ , onRecordField -- | Values of these types are produces by the parser. They use -- unadorned names and have no type information, apart from that@@ -160,7 +161,7 @@ modifyShapeAnnotations :: (oldshape -> newshape) -> TypeBase oldshape as -> TypeBase newshape as-modifyShapeAnnotations f = bimap f id+modifyShapeAnnotations = first -- | Return the uniqueness of a type. uniqueness :: TypeBase shape as -> Uniqueness@@ -238,7 +239,7 @@ arrayOfWithAliases (Array as1 _ et shape1) as2 shape2 u = Array (as1<>as2) u et (shape2 <> shape1) arrayOfWithAliases (Scalar t) as shape u =- Array as u (bimap id (const ()) t) shape+ Array as u (second (const ()) t) shape -- | @stripArray n t@ removes the @n@ outermost layers of the array. -- Essentially, it is the type of indexing an array of type @t@ with@@ -325,7 +326,7 @@ -- aliasing replaced by @f@ applied to that aliasing. addAliases :: TypeBase dim asf -> (asf -> ast) -> TypeBase dim ast-addAliases t f = bimap id f t+addAliases = flip second intValueType :: IntValue -> IntType intValueType Int8Value{} = Int8@@ -363,6 +364,14 @@ onDim (NamedDim qn) | qualLeaf qn `S.member` bound_here = AnyDim onDim d = d +-- | Perform some operation on a given record field.+onRecordField :: (TypeBase dim als -> TypeBase dim als)+ -> [Name]+ -> TypeBase dim als -> TypeBase dim als+onRecordField f (k:ks) (Scalar (Record m)) =+ Scalar $ Record $ M.adjust (onRecordField f ks) k m+onRecordField f _ t = f t+ -- | The type of an Futhark term. The aliasing will refer to itself, if -- the term is a non-tuple-typed variable. typeOf :: ExpBase Info VName -> PatternType@@ -608,13 +617,14 @@ ("zip", IntrinsicPolyFun [tp_a, tp_b] [arr_a, arr_b] arr_a_b), ("unzip", IntrinsicPolyFun [tp_a, tp_b] [arr_a_b] t_arr_a_arr_b), - ("gen_reduce", IntrinsicPolyFun [tp_a]- [uarr_a,- Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),- Scalar t_a,- Array () Nonunique (Prim $ Signed Int32) (rank 1),- arr_a]- uarr_a),+ ("hist", IntrinsicPolyFun [tp_a]+ [Scalar $ Prim $ Signed Int32,+ uarr_a,+ Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a),+ Scalar t_a,+ Array () Nonunique (Prim $ Signed Int32) (rank 1),+ arr_a]+ uarr_a), ("map", IntrinsicPolyFun [tp_a, tp_b] [Scalar t_a `arr` Scalar t_b, arr_a] uarr_b), @@ -736,8 +746,8 @@ intrinsicBinOp Band = binOp anyIntType intrinsicBinOp Xor = binOp anyIntType intrinsicBinOp Bor = binOp anyIntType- intrinsicBinOp LogAnd = Just $ IntrinsicMonoFun [Bool,Bool] Bool- intrinsicBinOp LogOr = Just $ IntrinsicMonoFun [Bool,Bool] Bool+ intrinsicBinOp LogAnd = binOp [Bool]+ intrinsicBinOp LogOr = binOp [Bool] intrinsicBinOp Equal = Just IntrinsicEquality intrinsicBinOp NotEqual = Just IntrinsicEquality intrinsicBinOp Less = ordering
src/Language/Futhark/Interpreter.hs view
@@ -23,7 +23,7 @@ import Control.Monad.Reader import qualified Control.Monad.Fail as Fail import Data.Array-import Data.Bifunctor (bimap)+import Data.Bifunctor (first) import Data.List hiding (break) import Data.Maybe import qualified Data.Map as M@@ -527,8 +527,8 @@ let (substs, types) = mconcat $ zipWith matchPtoA ps args onDim (NamedDim v) = fromMaybe (NamedDim v) $ M.lookup (qualLeaf v) substs onDim d = d- in if null ps then bimap onDim id t'- else evalType (Env mempty types mempty <> env) $ bimap onDim id t'+ in if null ps then first onDim t'+ else evalType (Env mempty types mempty <> env) $ first onDim t' Nothing -> t where matchPtoA (TypeParamDim p _) (TypeArgDim (NamedDim qv) _) =@@ -655,7 +655,7 @@ return $ ValuePrim $ FloatValue $ floatValue ft v _ -> error $ "eval: nonsensical type for float literal: " ++ pretty t -eval env (BinOp op op_t (x, _) (y, _) _ loc)+eval env (BinOp (op, _) op_t (x, _) (y, _) _ loc) | baseString (qualLeaf op) == "&&" = do x' <- asBool <$> eval env x if x'@@ -833,7 +833,7 @@ ModuleFun $ \m -> onModule <$> f (substituteInModule rev_substs m) onTerm (TermValue t v) = TermValue t v onTerm (TermModule m) = TermModule $ onModule m- onType (T.TypeAbbr l ps t) = T.TypeAbbr l ps $ bimap onDim id t+ onType (T.TypeAbbr l ps t) = T.TypeAbbr l ps $ first onDim t onDim (NamedDim v) = NamedDim $ replaceQ v onDim (ConstDim x) = ConstDim x onDim AnyDim = AnyDim@@ -995,10 +995,10 @@ case fromTuple v of Just [x,y,z] -> f x y z _ -> error $ "Expected triple; got: " ++ pretty v - fun5t f =+ fun6t f = TermValue Nothing $ ValueFun $ \v ->- case fromTuple v of Just [x,y,z,a,b] -> f x y z a b- _ -> error $ "Expected quintuple; got: " ++ pretty v+ case fromTuple v of Just [x,y,z,a,b,c] -> f x y z a b c+ _ -> error $ "Expected sextuple; got: " ++ pretty v bopDef fs = fun2 $ \x y -> case (x, y) of@@ -1025,6 +1025,17 @@ x' <- valf x retf =<< op x' + tbopDef f = fun1 $ \v ->+ case fromTuple v of+ Just [ValuePrim x, ValuePrim y]+ | Just x' <- getV x,+ Just y' <- getV y,+ Just z <- f x' y' ->+ return $ ValuePrim $ putV z+ _ ->+ bad noLoc mempty $ "Cannot apply operator to argument `" <>+ pretty v <> "."+ def "!" = Just $ unopDef [ (getS, putS, P.doUnOp $ P.Complement Int8) , (getS, putS, P.doUnOp $ P.Complement Int16) , (getS, putS, P.doUnOp $ P.Complement Int32)@@ -1040,7 +1051,7 @@ def "*" = arithOp P.Mul P.FMul def "**" = arithOp P.Pow P.FPow def "/" = Just $ bopDef $ sintOp P.SDiv ++ uintOp P.UDiv ++ floatOp P.FDiv- def "%" = Just $ bopDef $ sintOp P.SMod ++ uintOp P.UMod+ def "%" = Just $ bopDef $ sintOp P.SMod ++ uintOp P.UMod ++ floatOp P.FMod def "//" = Just $ bopDef $ sintOp P.SQuot ++ uintOp P.UDiv def "%%" = Just $ bopDef $ sintOp P.SRem ++ uintOp P.UMod def "^" = Just $ bopDef $ intOp P.Xor@@ -1074,18 +1085,25 @@ def s | Just bop <- find ((s==) . pretty) P.allBinOps =- Just $ bopDef [(getV, Just . putV, P.doBinOp bop)]+ Just $ tbopDef $ P.doBinOp bop+ | Just unop <- find ((s==) . pretty) P.allCmpOps =+ Just $ tbopDef $ \x y -> P.BoolValue <$> P.doCmpOp unop x y | Just cop <- find ((s==) . pretty) P.allConvOps = Just $ unopDef [(getV, Just . putV, P.doConvOp cop)] | Just unop <- find ((s==) . pretty) P.allUnOps = Just $ unopDef [(getV, Just . putV, P.doUnOp unop)]- | Just unop <- find ((s==) . pretty) P.allCmpOps =- Just $ bopDef [(getV, bool, P.doCmpOp unop)] | Just (pts, _, f) <- M.lookup s P.primFuns = case length pts of 1 -> Just $ unopDef [(getV, Just . putV, f . pure)]- _ -> Just $ bopDef [(getV, Just . putV, \x y -> f [x,y])]+ _ -> Just $ fun1 $ \x -> do+ let getV' (ValuePrim v) = getV v+ getV' _ = Nothing+ case f =<< mapM getV' =<< fromTuple x of+ Just res ->+ return $ ValuePrim $ putV res+ _ ->+ error $ "Cannot apply " ++ pretty s ++ " to " ++ pretty x | "sign_" `isPrefixOf` s = Just $ fun1 $ \x ->@@ -1097,7 +1115,6 @@ case x of (ValuePrim (SignedValue x')) -> return $ ValuePrim $ UnsignedValue x' _ -> error $ "Cannot unsign: " ++ pretty x- where bool = Just . BoolValue def s | "map_stream" `isPrefixOf` s = Just $ fun2t stream@@ -1128,13 +1145,13 @@ if i >= 0 && i < arrayLength arr' then arr' // [(i, v)] else arr' - def "gen_reduce" = Just $ fun5t $ \arr fun _ is vs ->+ def "hist" = Just $ fun6t $ \_ arr fun _ is vs -> case arr of ValueArray arr' -> ValueArray <$> foldM (update fun) arr' (zip (map asInt $ fromArray is) (fromArray vs)) _ ->- error $ "gen_reduce expects array, but got: " ++ pretty arr+ error $ "hist expects array, but got: " ++ pretty arr where update fun arr' (i, v) = if i >= 0 && i < arrayLength arr' then do
src/Language/Futhark/Parser/Lexer.x view
@@ -155,11 +155,11 @@ indexing :: T.Text -> Alex Name indexing s = case keyword s of ID v -> return v- _ -> fail $ "Cannot index keyword '" ++ T.unpack s ++ "'."+ _ -> alexError $ "Cannot index keyword '" ++ T.unpack s ++ "'." mkQualId :: T.Text -> Alex ([Name], Name) mkQualId s = case reverse $ T.splitOn "." s of- [] -> fail "mkQualId: no components"+ [] -> error "mkQualId: no components" k:qs -> return (map nameFromText (reverse qs), nameFromText k) -- | Suffix a zero if the last character is dot.@@ -169,7 +169,7 @@ tryRead :: Read a => String -> T.Text -> Alex a tryRead desc s = case reads s' of [(x, "")] -> return x- _ -> fail $ "Invalid " ++ desc ++ " literal: `" ++ T.unpack s ++ "'."+ _ -> error $ "Invalid " ++ desc ++ " literal: `" ++ T.unpack s ++ "'." where s' = T.unpack s readIntegral :: Integral a => T.Text -> a@@ -269,7 +269,7 @@ readHexRealLit desc s = case fromHexRealLit s of Just (n) -> return n- Nothing -> fail $ "Invalid " ++ desc ++ " literal: " ++ T.unpack s+ Nothing -> error $ "Invalid " ++ desc ++ " literal: " ++ T.unpack s alexGetPosn :: Alex (Int, Int, Int) alexGetPosn = Alex $ \s ->
src/Language/Futhark/Parser/Parser.y view
@@ -332,11 +332,11 @@ -- Note that this production does not include Minus, but does include -- operator sections.-BinOp :: { QualName Name }+BinOp :: { (QualName Name, SrcLoc) } : '+...' { binOpName $1 } | '-...' { binOpName $1 } | '*...' { binOpName $1 }- | '*' { qualName (nameFromString "*") }+ | '*' { (qualName (nameFromString "*"), $1) } | '/...' { binOpName $1 } | '%...' { binOpName $1 } | '//...' { binOpName $1 }@@ -351,25 +351,27 @@ | '||...' { binOpName $1 } | '**...' { binOpName $1 } | '^...' { binOpName $1 }- | '^' { qualName (nameFromString "^") }+ | '^' { (qualName (nameFromString "^"), $1) } | '&...' { binOpName $1 } | '|...' { binOpName $1 }- | '|' { qualName (nameFromString "|") }+ | '|' { (qualName (nameFromString "|"), $1) } | '>>...' { binOpName $1 } | '<<...' { binOpName $1 } | '<|...' { binOpName $1 } | '|>...' { binOpName $1 }- | '<' { qualName (nameFromString "<") }- | '`' QualName '`' { fst $2 }+ | '<' { (qualName (nameFromString "<"), $1) }+ | '`' QualName '`' { $2 } BindingUnOp :: { Name }- : UnOp {% let (QualName qs name, _) = $1 in do- unless (null qs) $ fail "Cannot use a qualified name in binding position."+ : UnOp {% let (QualName qs name, loc) = $1 in do+ unless (null qs) $ parseErrorAt loc $+ Just "Cannot use a qualified name in binding position." return name } BindingBinOp :: { Name }- : BinOp {% let QualName qs name = $1 in do- unless (null qs) $ fail "Cannot use a qualified name in binding position."+ : BinOp {% let (QualName qs name, loc) = $1 in do+ unless (null qs) $ parseErrorAt loc $+ Just "Cannot use a qualified name in binding position." return name } | '-' { nameFromString "-" } @@ -569,7 +571,7 @@ | Exp2 '<|...' Exp2 { binOp $1 $2 $3 } | Exp2 '<' Exp2 { binOp $1 (L $2 (SYMBOL Less [] (nameFromString "<"))) $3 }- | Exp2 '`' QualName '`' Exp2 { BinOp (fst $3) NoInfo ($1, NoInfo) ($5, NoInfo) NoInfo (srclocOf $1) }+ | Exp2 '`' QualName '`' Exp2 { BinOp $3 NoInfo ($1, NoInfo) ($5, NoInfo) NoInfo (srcspan $1 $>) } | Exp2 '...' Exp2 { Range $1 Nothing (ToInclusive $3) NoInfo (srcspan $1 $>) } | Exp2 '..<' Exp2 { Range $1 Nothing (UpToExclusive $3) NoInfo (srcspan $1 $>) }@@ -643,11 +645,11 @@ { OpSectionLeft (qualName (nameFromString "-")) NoInfo $2 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) } | '(' BinOp Exp2 ')'- { OpSectionRight $2 NoInfo $3 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }+ { OpSectionRight (fst $2) NoInfo $3 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) } | '(' Exp2 BinOp ')'- { OpSectionLeft $3 NoInfo $2 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }+ { OpSectionLeft (fst $3) NoInfo $2 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) } | '(' BinOp ')'- { OpSection $2 NoInfo (srcspan $1 $>) }+ { OpSection (fst $2) NoInfo (srcspan $1 $>) } | '(' FieldAccess FieldAccesses ')' { ProjectSection (map fst ($2:$3)) NoInfo (srcspan $1 $>) }@@ -881,7 +883,7 @@ | { [] } PrimType :: { PrimType }- : id {% let L _ (ID s) = $1 in primTypeFromName s }+ : id {% let L loc (ID s) = $1 in primTypeFromName loc s } IntValue :: { Value } : SignedLit { PrimValue (SignedValue (fst $1)) }@@ -1048,10 +1050,10 @@ eof :: Pos -> L Token eof pos = L (SrcLoc $ Loc pos pos) EOF -binOpName (L _ (SYMBOL _ qs op)) = QualName qs op+binOpName (L loc (SYMBOL _ qs op)) = (QualName qs op, loc) -binOp x (L _ (SYMBOL _ qs op)) y =- BinOp (QualName qs op) NoInfo (x, NoInfo) (y, NoInfo) NoInfo $+binOp x (L loc (SYMBOL _ qs op)) y =+ BinOp (QualName qs op, loc) NoInfo (x, NoInfo) (y, NoInfo) NoInfo $ srcspan x y getTokens :: ParserMonad ([L Token], Pos)@@ -1060,9 +1062,9 @@ putTokens :: ([L Token], Pos) -> ParserMonad () putTokens = lift . lift . put -primTypeFromName :: Name -> ParserMonad PrimType-primTypeFromName s = maybe boom return $ M.lookup s namesToPrimTypes- where boom = fail $ "No type named " ++ nameToString s+primTypeFromName :: SrcLoc -> Name -> ParserMonad PrimType+primTypeFromName loc s = maybe boom return $ M.lookup s namesToPrimTypes+ where boom = parseErrorAt loc $ Just $ "No type named " ++ nameToString s getFilename :: ParserMonad FilePath getFilename = lift $ gets parserFile
src/Language/Futhark/Pretty.hs view
@@ -114,7 +114,7 @@ ppr = pprPrec 0 pprPrec _ (Prim et) = ppr et pprPrec _ (TypeVar _ u et targs) =- ppr u <> ppr (qualNameFromTypeName et) <+> spread (map ppr targs)+ ppr u <> ppr (qualNameFromTypeName et) <+> spread (map (pprPrec 1) targs) pprPrec _ (Record fs) | Just ts <- areTupleFields fs = parens $ commasep $ map ppr ts@@ -128,19 +128,22 @@ parens (pprName v <> colon <+> ppr t1) <+> text "->" <+> ppr t2 pprPrec p (Arrow _ Unnamed t1 t2) = parensIf (p > 0) $ pprPrec 1 t1 <+> text "->" <+> ppr t2- pprPrec _ (Sum cs) =+ pprPrec p (Sum cs) =+ parensIf (p > 0) $ oneLine (mconcat $ punctuate (text " | ") cs') <|> align (mconcat $ punctuate (text " |" <> line) cs')- where ppConstr (name, fs) = sep $ (text "#" <> ppr name) : map ppr fs+ where ppConstr (name, fs) = sep $ (text "#" <> ppr name) : map (pprPrec 1) fs cs' = map ppConstr $ M.toList cs instance Pretty (ShapeDecl dim) => Pretty (TypeBase dim as) where- ppr (Array _ u at shape) = ppr u <> ppr shape <> ppr at- ppr (Scalar t) = ppr t+ ppr = pprPrec 0+ pprPrec _ (Array _ u at shape) = ppr u <> ppr shape <> ppr at+ pprPrec p (Scalar t) = pprPrec p t instance Pretty (ShapeDecl dim) => Pretty (TypeArg dim) where- ppr (TypeArgDim d _) = ppr $ ShapeDecl [d]- ppr (TypeArgType t _) = ppr t+ ppr = pprPrec 0+ pprPrec _ (TypeArgDim d _) = ppr $ ShapeDecl [d]+ pprPrec p (TypeArgType t _) = pprPrec p t instance (Eq vn, IsName vn) => Pretty (TypeExp vn) where ppr (TEUnique t _) = text "*" <> ppr t@@ -219,7 +222,7 @@ DownToExclusive end' -> text "..>" <> ppr end' ToInclusive end' -> text "..." <> ppr end' UpToExclusive end' -> text "..<" <> ppr end'- pprPrec p (BinOp bop _ (x,_) (y,_) _ _) = prettyBinOp p bop x y+ pprPrec p (BinOp (bop, _) _ (x,_) (y,_) _ _) = prettyBinOp p bop x y pprPrec _ (Project k e _ _) = ppr e <> text "." <> ppr k pprPrec _ (If c t f _ _) = text "if" <+> ppr c </> text "then" <+> align (ppr t) </>
src/Language/Futhark/Syntax.hs view
@@ -630,7 +630,7 @@ (ExpBase f vn) -- Loop body. SrcLoc - | BinOp (QualName vn) (f PatternType)+ | BinOp (QualName vn, SrcLoc) (f PatternType) (ExpBase f vn, f StructType) (ExpBase f vn, f StructType) (f PatternType) SrcLoc
src/Language/Futhark/Traversals.hs view
@@ -73,8 +73,9 @@ astMap tv (Ascript e tdecl t loc) = Ascript <$> mapOnExp tv e <*> astMap tv tdecl <*> traverse (mapOnPatternType tv) t <*> pure loc- astMap tv (BinOp fname t (x,xt) (y,yt) (Info rt) loc) =- BinOp <$> mapOnQualName tv fname <*> traverse (mapOnPatternType tv) t <*>+ astMap tv (BinOp (fname, fname_loc) t (x,xt) (y,yt) (Info rt) loc) =+ BinOp <$> ((,) <$> mapOnQualName tv fname <*> pure fname_loc) <*>+ traverse (mapOnPatternType tv) t <*> ((,) <$> mapOnExp tv x <*> traverse (mapOnStructType tv) xt) <*> ((,) <$> mapOnExp tv y <*> traverse (mapOnStructType tv) yt) <*> (Info <$> mapOnPatternType tv rt) <*> pure loc
src/Language/Futhark/TypeChecker/Monad.hs view
@@ -5,12 +5,13 @@ ( TypeM , runTypeM , askEnv- , askRootEnv , askImportName- , localTmpEnv , checkQualNameWithEnv , bindSpaced , qualifyTypeVars+ , lookupMTy+ , lookupImport+ , localEnv , TypeError(..) , unexpectedType@@ -126,7 +127,6 @@ type ImportTable = M.Map String Env data Context = Context { contextEnv :: Env- , contextRootEnv :: Env , contextImportTable :: ImportTable , contextImportName :: ImportName }@@ -148,21 +148,38 @@ -> TypeM a -> Either TypeError (a, Warnings, VNameSource) runTypeM env imports fpath src (TypeM m) = do- (x, src', ws) <- runExcept $ runRWST m (Context env env imports fpath) src+ (x, src', ws) <- runExcept $ runRWST m (Context env imports fpath) src return (x, ws, src') -askEnv, askRootEnv :: TypeM Env+askEnv :: TypeM Env askEnv = asks contextEnv-askRootEnv = asks contextRootEnv -- | The name of the current file/import. askImportName :: TypeM ImportName askImportName = asks contextImportName -localTmpEnv :: Env -> TypeM a -> TypeM a-localTmpEnv env = local $ \ctx ->- ctx { contextEnv = env <> contextEnv ctx }+lookupMTy :: SrcLoc -> QualName Name -> TypeM (QualName VName, MTy)+lookupMTy loc qn = do+ (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Signature qn loc+ (qn',) <$> maybe explode return (M.lookup name $ envSigTable scope)+ where explode = unknownVariableError Signature qn loc +lookupImport :: SrcLoc -> FilePath -> TypeM (FilePath, Env)+lookupImport loc file = do+ imports <- asks contextImportTable+ my_path <- asks contextImportName+ let canonical_import = includeToString $ mkImportFrom my_path file loc+ case M.lookup canonical_import imports of+ Nothing -> throwError $ TypeError loc $+ unlines ["Unknown import \"" ++ canonical_import ++ "\"",+ "Known: " ++ intercalate ", " (M.keys imports)]+ Just scope -> return (canonical_import, scope)++localEnv :: Env -> TypeM a -> TypeM a+localEnv env = local $ \ctx ->+ let env' = env <> contextEnv ctx+ in ctx { contextEnv = env' }+ -- | A piece of information that describes what process the type -- checker currently performing. This is used to give better error -- messages.@@ -200,14 +217,12 @@ newID :: Name -> m VName bindNameMap :: NameMap -> m a -> m a- localEnv :: Env -> m a -> m a+ bindVal :: VName -> BoundV -> m a -> m a checkQualName :: Namespace -> QualName Name -> SrcLoc -> m (QualName VName) lookupType :: SrcLoc -> QualName Name -> m (QualName VName, [TypeParam], StructType, Liftedness) lookupMod :: SrcLoc -> QualName Name -> m (QualName VName, Mod)- lookupMTy :: SrcLoc -> QualName Name -> m (QualName VName, MTy)- lookupImport :: SrcLoc -> FilePath -> m (FilePath, Env) lookupVar :: SrcLoc -> QualName Name -> m (QualName VName, PatternType) checkNamedDim :: SrcLoc -> QualName Name -> m (QualName VName)@@ -241,14 +256,14 @@ let env = contextEnv ctx in ctx { contextEnv = env { envNameMap = m <> envNameMap env } } - localEnv env = local $ \ctx ->- let env' = env <> contextEnv ctx- in ctx { contextEnv = env', contextRootEnv = env' }+ bindVal v t = local $ \ctx ->+ ctx { contextEnv = (contextEnv ctx)+ { envVtable = M.insert v t $ envVtable $ contextEnv ctx } } checkQualName space name loc = snd <$> checkQualNameWithEnv space name loc lookupType loc qn = do- outer_env <- askRootEnv+ outer_env <- askEnv (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc case M.lookup name $ envTypeTable scope of Nothing -> undefinedType loc qn@@ -260,23 +275,8 @@ Nothing -> unknownVariableError Term qn loc Just m -> return (qn', m) - lookupMTy loc qn = do- (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Signature qn loc- (qn',) <$> maybe explode return (M.lookup name $ envSigTable scope)- where explode = unknownVariableError Signature qn loc-- lookupImport loc file = do- imports <- asks contextImportTable- my_path <- asks contextImportName- let canonical_import = includeToString $ mkImportFrom my_path file loc- case M.lookup canonical_import imports of- Nothing -> throwError $ TypeError loc $- unlines ["Unknown import \"" ++ canonical_import ++ "\"",- "Known: " ++ intercalate ", " (M.keys imports)]- Just scope -> return (canonical_import, scope)- lookupVar loc qn = do- outer_env <- askRootEnv+ outer_env <- askEnv (env, qn'@(QualName qs name)) <- checkQualNameWithEnv Term qn loc case M.lookup name $ envVtable env of Nothing -> unknownVariableError Term qn loc
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -149,29 +149,37 @@ deriving (Show) -- | Type checking happens with access to this environment. The--- tables will be extended during type-checking as bindings come into+-- 'TermScope' will be extended during type-checking as bindings come into -- scope.+data TermEnv = TermEnv { termScope :: TermScope+ , termBreadCrumbs :: [BreadCrumb]+ -- ^ Most recent first.+ }+ data TermScope = TermScope { scopeVtable :: M.Map VName ValBinding , scopeTypeTable :: M.Map VName TypeBinding+ , scopeModTable :: M.Map VName Mod , scopeNameMap :: NameMap- , scopeBreadCrumbs :: [BreadCrumb]- -- ^ Most recent first. } deriving (Show) instance Semigroup TermScope where- TermScope vt1 tt1 nt1 bc1 <> TermScope vt2 tt2 nt2 bc2 =- TermScope (vt2 `M.union` vt1) (tt2 `M.union` tt1) (nt2 `M.union` nt1) (bc1 <> bc2)--instance Monoid TermScope where- mempty = TermScope mempty mempty mempty mempty+ TermScope vt1 tt1 mt1 nt1 <> TermScope vt2 tt2 mt2 nt2 =+ TermScope (vt2 `M.union` vt1) (tt2 `M.union` tt1) (mt1 `M.union` mt2) (nt2 `M.union` nt1) envToTermScope :: Env -> TermScope-envToTermScope env = TermScope vtable (envTypeTable env) (envNameMap env) mempty+envToTermScope env = TermScope { scopeVtable = vtable+ , scopeTypeTable = envTypeTable env+ , scopeNameMap = envNameMap env+ , scopeModTable = envModTable env+ } where vtable = M.mapWithKey valBinding $ envVtable env valBinding k (TypeM.BoundV tps v) = BoundV Global tps $ v `setAliases` (if arrayRank v > 0 then S.singleton (AliasBound k) else mempty) +withEnv :: TermEnv -> Env -> TermEnv+withEnv tenv env = tenv { termScope = termScope tenv <> envToTermScope env }+ constraintTypeVars :: Constraints -> Names constraintTypeVars = mconcat . map f . M.elems where f (Constraint t _) = typeVars t@@ -194,13 +202,13 @@ type TermTypeState = (Constraints, Int) newtype TermTypeM a = TermTypeM (RWST- TermScope+ TermEnv Occurences TermTypeState TypeM a) deriving (Monad, Functor, Applicative,- MonadReader TermScope,+ MonadReader TermEnv, MonadWriter Occurences, MonadState TermTypeState, MonadError TypeError)@@ -220,31 +228,44 @@ instance MonadBreadCrumbs TermTypeM where breadCrumb bc = local $ \env ->- env { scopeBreadCrumbs = bc : scopeBreadCrumbs env }- getBreadCrumbs = asks scopeBreadCrumbs+ env { termBreadCrumbs = bc : termBreadCrumbs env }+ getBreadCrumbs = asks termBreadCrumbs runTermTypeM :: TermTypeM a -> TypeM (a, Occurences) runTermTypeM (TermTypeM m) = do- initial_scope <- (initialTermScope <>) <$> (envToTermScope <$> askEnv)- evalRWST m initial_scope (mempty, 0)+ initial_scope <- (initialTermScope <>) . envToTermScope <$> askEnv+ let initial_tenv = TermEnv { termScope = initial_scope+ , termBreadCrumbs = mempty+ }+ evalRWST m initial_tenv (mempty, 0) liftTypeM :: TypeM a -> TermTypeM a liftTypeM = TermTypeM . lift +localScope :: (TermScope -> TermScope) -> TermTypeM a -> TermTypeM a+localScope f = local $ \tenv -> tenv { termScope = f $ termScope tenv }+ incCounter :: TermTypeM Int incCounter = do (x, i) <- get put (x, i+1) return i initialTermScope :: TermScope-initialTermScope = TermScope initialVtable mempty topLevelNameMap mempty+initialTermScope = TermScope { scopeVtable = initialVtable+ , scopeTypeTable = mempty+ , scopeNameMap = topLevelNameMap+ , scopeModTable = mempty+ } where initialVtable = M.fromList $ mapMaybe addIntrinsicF $ M.toList intrinsics - funF ts t = foldr (arrow . Scalar . Prim) (Scalar $ Prim t) ts+ prim = Scalar . Prim arrow x y = Scalar $ Arrow mempty Unnamed x y - addIntrinsicF (name, IntrinsicMonoFun ts t) =- Just (name, BoundV Global [] $ funF ts t)+ addIntrinsicF (name, IntrinsicMonoFun pts t) =+ Just (name, BoundV Global [] $ arrow pts' $ prim t)+ where pts' = case pts of [pt] -> prim pt+ _ -> tupleRecord $ map prim pts+ addIntrinsicF (name, IntrinsicOverloadedFun ts pts rts) = Just (name, OverloadedF ts pts rts) addIntrinsicF (name, IntrinsicPolyFun tvs pts rt) =@@ -266,34 +287,29 @@ checkQualName space name loc = snd <$> checkQualNameWithEnv space name loc - bindNameMap m = local $ \scope ->+ bindNameMap m = localScope $ \scope -> scope { scopeNameMap = m <> scopeNameMap scope } - localEnv env (TermTypeM m) = do- cur_state <- get- cur_scope <- ask- let cur_scope' =- cur_scope { scopeNameMap = scopeNameMap cur_scope `M.difference` envNameMap env }- (x,new_state,occs) <- liftTypeM $ localTmpEnv env $- runRWST m cur_scope' cur_state- tell occs- put new_state- return x+ bindVal v (TypeM.BoundV tps t) = localScope $ \scope ->+ scope { scopeVtable = M.insert v vb $ scopeVtable scope }+ where vb = BoundV Local tps $ fromStruct t lookupType loc qn = do- outer_env <- liftTypeM askRootEnv+ outer_env <- liftTypeM askEnv (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc case M.lookup name $ scopeTypeTable scope of Nothing -> undefinedType loc qn Just (TypeAbbr l ps def) -> return (qn', ps, qualifyTypeVars outer_env (map typeParamName ps) qs def, l) - lookupMod loc name = liftTypeM $ TypeM.lookupMod loc name- lookupMTy loc name = liftTypeM $ TypeM.lookupMTy loc name- lookupImport loc name = liftTypeM $ TypeM.lookupImport loc name+ lookupMod loc qn = do+ (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Term qn loc+ case M.lookup name $ scopeModTable scope of+ Nothing -> unknownVariableError Term qn loc+ Just m -> return (qn', m) lookupVar loc qn = do- outer_env <- liftTypeM askRootEnv+ outer_env <- liftTypeM askEnv (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Term qn loc let usage = mkUsage loc $ "use of " ++ quote (pretty qn) @@ -342,37 +358,41 @@ return v' checkQualNameWithEnv :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)-checkQualNameWithEnv space qn@(QualName [q] _) loc- | nameToString q == "intrinsics" = do- -- Check if we are referring to the magical intrinsics- -- module.- (_, QualName _ q') <- liftTypeM $ TypeM.checkQualNameWithEnv Term (qualName q) loc- if baseTag q' <= maxIntrinsicTag- then checkIntrinsic space qn loc- else checkReallyQualName space qn loc checkQualNameWithEnv space qn@(QualName quals name) loc = do- scope <- ask- case quals of- [] | Just name' <- M.lookup (space, name) $ scopeNameMap scope ->- return (scope, name')- _ -> checkReallyQualName space qn loc+ scope <- asks termScope+ descend scope quals+ where descend scope []+ | Just name' <- M.lookup (space, name) $ scopeNameMap scope =+ return (scope, name')+ | otherwise =+ unknownVariableError space qn loc + descend scope (q:qs)+ | Just (QualName _ q') <- M.lookup (Term, q) $ scopeNameMap scope,+ Just res <- M.lookup q' $ scopeModTable scope =+ case res of+ -- Check if we are referring to the magical intrinsics+ -- module.+ _ | baseTag q' <= maxIntrinsicTag ->+ checkIntrinsic space qn loc+ ModEnv q_scope -> do+ (scope', QualName qs' name') <- descend (envToTermScope q_scope) qs+ return (scope', QualName (q':qs') name')+ ModFun{} -> unappliedFunctor loc+ | otherwise =+ unknownVariableError space qn loc+ checkIntrinsic :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName) checkIntrinsic space qn@(QualName _ name) loc | Just v <- M.lookup (space, name) intrinsicsNameMap = do me <- liftTypeM askImportName unless ("/futlib" `isPrefixOf` includeToString me) $ warn loc "Using intrinsic functions directly can easily crash the compiler or result in wrong code generation."- scope <- ask+ scope <- asks termScope return (scope, v) | otherwise = unknownVariableError space qn loc -checkReallyQualName :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName)-checkReallyQualName space qn loc = do- (env, name') <- liftTypeM $ TypeM.checkQualNameWithEnv space qn loc- return (envToTermScope env, name')- -- | Wrap 'Types.checkTypeDecl' to also perform an observation of -- every size in the type. checkTypeDecl :: TypeDeclBase NoInfo Name -> TermTypeM (TypeDeclBase Info VName)@@ -418,6 +438,10 @@ --- Errors +funName :: Maybe Name -> String+funName Nothing = "anonymous function"+funName (Just fname) = "function " ++ quote (pretty fname)+ useAfterConsume :: MonadTypeChecker m => Name -> SrcLoc -> SrcLoc -> m a useAfterConsume name rloc wloc = throwError $ TypeError rloc $@@ -434,17 +458,17 @@ throwError $ TypeError loc "New value for elements in let-with shares data with source array. This is illegal, as it prevents in-place modification." -returnAliased :: MonadTypeChecker m => Name -> Name -> SrcLoc -> m ()+returnAliased :: MonadTypeChecker m => Maybe Name -> Name -> SrcLoc -> m () returnAliased fname name loc = throwError $ TypeError loc $- "Unique return value of function " ++ quote (pretty fname) +++ "Unique return value of " ++ funName fname ++ " is aliased to " ++ quote (pretty name) ++ ", which is not consumed." -uniqueReturnAliased :: MonadTypeChecker m => Name -> SrcLoc -> m a+uniqueReturnAliased :: MonadTypeChecker m => Maybe Name -> SrcLoc -> m a uniqueReturnAliased fname loc = throwError $ TypeError loc $- "A unique tuple element of return value of `" ++- quote (pretty fname) ++ "` is aliased to some other tuple component."+ "A unique tuple element of return value of " +++ funName fname ++ " is aliased to some other tuple component." --- Basic checking @@ -475,6 +499,9 @@ --- General binding. +doNotShadow :: [String]+doNotShadow = ["&&", "||"]+ data InferredType = NoneInferred | Ascribed PatternType @@ -485,11 +512,16 @@ checkPattern' (PatternParens p loc) t = PatternParens <$> checkPattern' p t <*> pure loc +checkPattern' (Id name _ loc) _+ | name' `elem` doNotShadow =+ typeError loc $ "The " ++ name' ++ " operator may not be redefined."+ where name' = nameToString name+ checkPattern' (Id name NoInfo loc) (Ascribed t) = do- name' <- checkName Term name loc+ name' <- newID name return $ Id name' (Info t) loc checkPattern' (Id name NoInfo loc) NoneInferred = do- name' <- checkName Term name loc+ name' <- newID name t <- newTypeVar loc "t" return $ Id name' (Info t) loc @@ -591,19 +623,19 @@ return $ PatternConstr n (Info t) ps' loc where usage = mkUsage loc "matching against constructor" -bindPatternNames :: PatternBase NoInfo Name -> TermTypeM a -> TermTypeM a-bindPatternNames = bindSpaced . map asTerm . S.toList . patternIdents- where asTerm v = (Term, identName v)+patternNameMap :: Pattern -> NameMap+patternNameMap = M.fromList . map asTerm . S.toList . patternIdents+ where asTerm v = ((Term, baseName $ identName v), qualName $ identName v) checkPattern :: UncheckedPattern -> InferredType -> (Pattern -> TermTypeM a) -> TermTypeM a checkPattern p t m = do checkForDuplicateNames [p]- bindPatternNames p $- m =<< checkPattern' p t+ p' <- checkPattern' p t+ bindNameMap (patternNameMap p') $ m p' binding :: [Ident] -> TermTypeM a -> TermTypeM a-binding bnds = check . local (`bindVars` bnds)+binding bnds = check . localScope (`bindVars` bnds) where bindVars :: TermScope -> [Ident] -> TermScope bindVars = foldl bindVar @@ -656,7 +688,7 @@ bindingTypes :: [(VName, (TypeBinding, Constraint))] -> TermTypeM a -> TermTypeM a bindingTypes types m = do modifyConstraints (<>M.map snd (M.fromList types))- local extend m+ localScope extend m where extend scope = scope { scopeTypeTable = M.map fst (M.fromList types) <> scopeTypeTable scope }@@ -755,7 +787,7 @@ -- it references, and which local to the current top-level function. lexicalClosure :: [Pattern] -> Occurences -> TermTypeM Aliasing lexicalClosure params closure = do- vtable <- asks scopeVtable+ vtable <- asks $ scopeVtable . termScope let isLocal v = case v `M.lookup` vtable of Just (BoundV Local _ _) -> True _ -> False@@ -864,15 +896,15 @@ return $ Ascript e' decl' (Info (combineTypeShapes t $ fromStruct decl_t)) loc -checkExp (BinOp op NoInfo (e1,_) (e2,_) NoInfo loc) = do- (op', ftype) <- lookupVar loc op+checkExp (BinOp (op, oploc) NoInfo (e1,_) (e2,_) NoInfo loc) = do+ (op', ftype) <- lookupVar oploc op (e1', e1_arg) <- checkArg e1 (e2', e2_arg) <- checkArg e2 (p1_t, rt) <- checkApply loc ftype e1_arg (p2_t, rt') <- checkApply loc rt e2_arg - return $ BinOp op' (Info ftype)+ return $ BinOp (op', oploc) (Info ftype) (e1', Info $ toStruct p1_t) (e2', Info $ toStruct p2_t) (Info rt') loc @@ -900,7 +932,7 @@ checkExp (QualParens modname e loc) = do (modname',mod) <- lookupMod loc modname case mod of- ModEnv env -> localEnv (qualifyEnv modname' env) $ do+ ModEnv env -> local (`withEnv` qualifyEnv modname' env) $ do e' <- checkExp e return $ QualParens modname' e' loc ModFun{} ->@@ -966,21 +998,24 @@ return $ LetPat pat' e' body' (Info body_t) loc checkExp (LetFun name (tparams, params, maybe_retdecl, NoInfo, e) body loc) =- sequentially (checkFunDef' (name, maybe_retdecl, tparams, params, e, loc)) $- \(name', tparams', params', maybe_retdecl', rettype, e') closure -> do+ sequentially (checkBinding (Just name, maybe_retdecl, tparams, params, e, loc)) $+ \(tparams', params', maybe_retdecl', rettype, e') closure -> do closure' <- lexicalClosure params' closure - let arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt- ftype = foldr (arrow . patternParam) rettype params'- entry = BoundV Local tparams' $ ftype `setAliases` closure'- bindF scope = scope { scopeVtable = M.insert name' entry $ scopeVtable scope- , scopeNameMap = M.insert (Term, name) (qualName name') $- scopeNameMap scope }- body' <- local bindF $ checkExp body+ bindSpaced [(Term, name)] $ do+ name' <- checkName Term name loc - return $ LetFun name' (tparams', params', maybe_retdecl', Info rettype, e') body' loc+ let arrow (xp, xt) yt = Scalar $ Arrow () xp xt yt+ ftype = foldr (arrow . patternParam) rettype params'+ entry = BoundV Local tparams' $ ftype `setAliases` closure'+ bindF scope = scope { scopeVtable = M.insert name' entry $ scopeVtable scope+ , scopeNameMap = M.insert (Term, name) (qualName name') $+ scopeNameMap scope }+ body' <- localScope bindF $ checkExp body + return $ LetFun name' (tparams', params', maybe_retdecl', Info rettype, e') body' loc+ checkExp (LetWith dest src idxes ve body NoInfo loc) = do (t, _) <- newArrayType (srclocOf src) "src" $ length idxes let elemt = stripArray (length $ filter isFix idxes) t@@ -991,7 +1026,7 @@ unless (unique $ unInfo $ identType src') $ typeError loc $ "Source " ++ quote (pretty (identName src)) ++ " has type " ++ pretty (unInfo $ identType src') ++ ", which is not unique."- vtable <- asks scopeVtable+ vtable <- asks $ scopeVtable . termScope forM_ (aliases $ unInfo $ identType src') $ \v -> case aliasVar v `M.lookup` vtable of Just (BoundV Local _ v_t)@@ -1041,8 +1076,10 @@ a <- expType src' let usage = mkUsage loc "record update" r <- foldM (flip $ mustHaveField usage) a fields- unify usage (toStructural r) . toStructural =<< expType ve'- return $ RecordUpdate src' fields ve' (Info a) loc+ ve_t <- expType ve'+ unify usage (toStructural r) (toStructural ve_t)+ a' <- onRecordField (`setAliases` aliases ve_t) fields <$> expType src'+ return $ RecordUpdate src' fields ve' (Info a') loc checkExp (Index e idxes NoInfo loc) = do (t, _) <- newArrayType (srclocOf e) "e" $ length idxes@@ -1243,7 +1280,7 @@ -- alias something bound outside the loop, AND that anything -- returned for a unique merge parameter does not alias anything -- else returned.- bound_outside <- asks $ S.fromList . M.keys . scopeVtable+ bound_outside <- asks $ S.fromList . M.keys . scopeVtable . termScope let checkMergeReturn (Id pat_v (Info pat_v_t) _) t | unique pat_v_t, v:_ <- S.toList $ S.map aliasVar (aliases t) `S.intersection` bound_outside =@@ -1660,25 +1697,32 @@ [UncheckedTypeParam], [UncheckedPattern], UncheckedExp, SrcLoc) -> TypeM (VName, [TypeParam], [Pattern], Maybe (TypeExp VName), StructType, Exp)-checkFunDef f = fmap fst $ runTermTypeM $ do- (fname, tparams, params, maybe_retdecl, rettype, body) <- checkFunDef' f+checkFunDef (fname, maybe_retdecl, tparams, params, body, loc) =+ fmap fst $ runTermTypeM $ do+ (tparams', params', maybe_retdecl', rettype', body') <-+ checkBinding (Just fname, maybe_retdecl, tparams, params, body, loc) -- Since this is a top-level function, we also resolve overloaded -- types, using either defaults or complaining about ambiguities. fixOverloadedTypes -- Then replace all inferred types in the body and parameters.- body' <- updateExpTypes body- params' <- updateExpTypes params- maybe_retdecl' <- traverse updateExpTypes maybe_retdecl- rettype' <- normaliseType rettype+ body'' <- updateExpTypes body'+ params'' <- updateExpTypes params'+ maybe_retdecl'' <- traverse updateExpTypes maybe_retdecl'+ rettype'' <- normaliseType rettype' -- Check if pattern matches are exhaustive and yield -- errors if not.- checkUnmatched body'+ checkUnmatched body'' - return (fname, tparams, params', maybe_retdecl', rettype', body')+ bindSpaced [(Term, fname)] $ do+ fname' <- checkName Term fname loc+ when (nameToString fname `elem` doNotShadow) $+ typeError loc $ "The " ++ nameToString fname ++ " operator may not be redefined." + return (fname', tparams', params'', maybe_retdecl'', rettype'', body'')+ -- | This is "fixing" as in "setting them", not "correcting them". We -- only make very conservative fixing. fixOverloadedTypes :: TermTypeM ()@@ -1718,16 +1762,11 @@ fixOverloaded _ = return () -checkFunDef' :: (Name, Maybe UncheckedTypeExp,+checkBinding :: (Maybe Name, Maybe UncheckedTypeExp, [UncheckedTypeParam], [UncheckedPattern], UncheckedExp, SrcLoc)- -> TermTypeM (VName, [TypeParam], [Pattern], Maybe (TypeExp VName), StructType, Exp)-checkFunDef' (fname, maybe_retdecl, tparams, params, body, loc) = noUnique $ do- when (nameToString fname == "&&") $- typeError loc "The && operator may not be redefined."- when (nameToString fname == "||") $- typeError loc "The || operator may not be redefined."-+ -> TermTypeM ([TypeParam], [Pattern], Maybe (TypeExp VName), StructType, Exp)+checkBinding (fname, maybe_retdecl, tparams, params, body, loc) = noUnique $ do then_substs <- getConstraints bindingPatternGroup tparams params $ \tparams' params' -> do@@ -1757,11 +1796,10 @@ let fun_t = foldFunType (map patternStructType params'') rettype tparams'' <- letGeneralise tparams' fun_t then_substs - bindSpaced [(Term, fname)] $ do- fname' <- checkName Term fname loc- checkGlobalAliases params'' body_t loc- return (fname', tparams'', params'', maybe_retdecl'', rettype, body')+ checkGlobalAliases params'' body_t loc + return (tparams'', params'', maybe_retdecl'', rettype, body')+ where -- | Check that unique return values do not alias a -- non-consumed parameter. checkReturnAlias rettp params' =@@ -1814,7 +1852,7 @@ checkGlobalAliases :: [Pattern] -> PatternType -> SrcLoc -> TermTypeM () checkGlobalAliases params body_t loc = do- vtable <- asks scopeVtable+ vtable <- asks $ scopeVtable . termScope let isLocal v = case v `M.lookup` vtable of Just (BoundV Local _ _) -> True _ -> False@@ -1978,7 +2016,7 @@ -- | Proclaim that we have written to the given variable. consume :: SrcLoc -> Aliasing -> TermTypeM () consume loc als = do- vtable <- asks scopeVtable+ vtable <- asks $ scopeVtable . termScope let consumable v = case M.lookup v vtable of Just (BoundV Local _ t) | arrayRank t > 0 -> unique t@@ -1995,7 +2033,7 @@ consuming :: Ident -> TermTypeM a -> TermTypeM a consuming (Ident name (Info t) loc) m = do consume loc $ AliasBound name `S.insert` aliases t- local consume' m+ localScope consume' m where consume' scope = scope { scopeVtable = M.insert name (WasConsumed loc) $ scopeVtable scope } @@ -2029,7 +2067,7 @@ -- | Make all bindings nonunique. noUnique :: TermTypeM a -> TermTypeM a-noUnique = local (\scope -> scope { scopeVtable = M.map set $ scopeVtable scope})+noUnique = localScope (\scope -> scope { scopeVtable = M.map set $ scopeVtable scope}) where set (BoundV l tparams t) = BoundV l tparams $ t `setUniqueness` Nonunique set (OverloadedF ts pts rt) = OverloadedF ts pts rt set EqualityF = EqualityF@@ -2037,7 +2075,7 @@ set (WasConsumed loc) = WasConsumed loc onlySelfAliasing :: TermTypeM a -> TermTypeM a-onlySelfAliasing = local (\scope -> scope { scopeVtable = M.mapWithKey set $ scopeVtable scope})+onlySelfAliasing = localScope (\scope -> scope { scopeVtable = M.mapWithKey set $ scopeVtable scope}) where set k (BoundV l tparams t) = BoundV l tparams $ t `addAliases` S.intersection (S.singleton (AliasBound k)) set _ (OverloadedF ts pts rt) = OverloadedF ts pts rt
src/Language/Futhark/TypeChecker/Types.hs view
@@ -32,13 +32,12 @@ import Data.List import Data.Loc import Data.Maybe-import Data.Monoid ((<>)) import qualified Data.Map.Strict as M import Language.Futhark import Language.Futhark.TypeChecker.Monad --- | @unifyTypes uf t2 t2@ attempts to unify @t1@ and @t2@. If+-- | @unifyTypes uf t1 t2@ attempts to unify @t1@ and @t2@. If -- unification cannot happen, 'Nothing' is returned, otherwise a type -- that combines the aliasing of @t1@ and @t2@ is returned. -- Uniqueness is unified with @uf@.@@ -166,8 +165,7 @@ (t1', st1, _) <- checkTypeExp t1 bindSpaced [(Term, v)] $ do v' <- checkName Term v loc- let env = mempty { envVtable = M.singleton v' $ BoundV [] st1 }- localEnv env $ do+ bindVal v' (BoundV [] st1) $ do (t2', st2, _) <- checkTypeExp t2 return (TEArrow (Just v') t1' t2' loc, Scalar $ Arrow mempty (Named v') st1 st2,@@ -462,4 +460,4 @@ TypeArgType (substTypesAny lookupSubst' t) loc subsTypeArg t = t - lookupSubst' = fmap (fmap $ bimap id (const ())) . lookupSubst+ lookupSubst' = fmap (fmap $ second (const ())) . lookupSubst
src/Language/Futhark/TypeChecker/Unify.hs view
@@ -97,13 +97,13 @@ normaliseType t = do constraints <- getConstraints return $ applySubst (`lookupSubst` constraints) t --- | Is the given type variable actually the name of an abstract type--- or type parameter, which we cannot substitute?+-- | Is the given type variable the name of an abstract type or type+-- parameter, which we cannot substitute? isRigid :: VName -> Constraints -> Bool isRigid v constraints = case M.lookup v constraints of- Nothing -> True- Just ParamType{} -> True- _ -> False+ Nothing -> True+ Just ParamType{} -> True+ _ -> False unifySharedConstructors :: MonadUnify m => Usage@@ -228,7 +228,8 @@ | tp `notElem` map (Scalar . Prim) ts -> case tp' of Scalar (TypeVar _ _ (TypeName [] v) [])- | not $ isRigid v constraints -> linkVarToTypes usage v ts+ | not $ isRigid v constraints ->+ linkVarToTypes usage v ts _ -> typeError usage $ "Cannot unify " ++ quote (prettyName vn) ++ "' with type\n" ++ indent (pretty tp) ++ "\nas " ++@@ -314,6 +315,16 @@ intercalate "," (map pretty ts) ++ " but also one of " ++ intercalate "," (map pretty vn_ts) ++ " due to " ++ show vn_usage ++ "." ts' -> modifyConstraints $ M.insert vn $ Overloaded ts' usage++ Just (HasConstrs _ vn_usage) ->+ typeError usage $ "Type constrained to one of " +++ intercalate "," (map pretty ts) ++ ", but also inferred to be sum type due to " +++ show vn_usage ++ "."++ Just (HasFields _ vn_usage) ->+ typeError usage $ "Type constrained to one of " +++ intercalate "," (map pretty ts) ++ ", but also inferred to be record due to " +++ show vn_usage ++ "." _ -> modifyConstraints $ M.insert vn $ Overloaded ts usage
src/futhark.hs view
@@ -33,6 +33,7 @@ import qualified Futhark.CLI.REPL as REPL import qualified Futhark.CLI.Run as Run import qualified Futhark.CLI.Misc as Misc+import qualified Futhark.CLI.Autotune as Autotune type Command = String -> [String] -> IO () @@ -54,16 +55,18 @@ , ("csopencl", (CSOpenCL.main, "Compile to C# calling OpenCL.")) , ("test", (Test.main, "Test Futhark programs."))- , ("bench", (Bench.main, "Test Futhark programs."))+ , ("bench", (Bench.main, "Benchmark Futhark programs.")) , ("dataset", (Dataset.main, "Generate random test data.")) , ("datacmp", (Datacmp.main, "Compare Futhark data files for equality."))+ , ("dataget", (Misc.mainDataget, "Extract test data.")) , ("doc", (Doc.main, "Generate documentation for Futhark code.")) , ("pkg", (Pkg.main, "Manage local packages.")) , ("check", (Misc.mainCheck, "Type check a program."))- , ("imports", (Misc.mainImports, "Print all non-library imported Futhark files to standard out and exit."))+ , ("imports", (Misc.mainImports, "Print all non-builtin imported Futhark files."))+ , ("autotune", (Autotune.main, "Autotune threshold parameters.")) ] msg :: String
unittests/Futhark/Analysis/ScalExpTests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Futhark.Analysis.ScalExpTests ( tests
+ unittests/Futhark/BenchTests.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Futhark.BenchTests (tests) where++import qualified Data.Text as T++import Test.Tasty+import Test.Tasty.QuickCheck++import Futhark.Bench++instance Arbitrary RunResult where+ arbitrary = RunResult . getPositive <$> arbitrary++printable :: Gen String+printable = getPrintableString <$> arbitrary++instance Arbitrary DataResult where+ arbitrary = DataResult+ <$> printable+ <*> oneof [Left <$> arbText,+ Right <$> ((,) <$> arbitrary <*> arbText)]+ where arbText = T.pack <$> printable++-- XXX: we restrict this generator to single datasets to we don't have+-- to worry about duplicates.+instance Arbitrary BenchResult where+ arbitrary = BenchResult <$> printable <*> (pure <$> arbitrary)++encodeDecodeJSON :: TestTree+encodeDecodeJSON = testProperty "encoding and decoding are inverse" prop+ where prop :: BenchResult -> Bool+ prop brs = decodeBenchResults (encodeBenchResults [brs]) == Right [brs]++tests :: TestTree+tests = testGroup "Futhark.BenchTests" [encodeDecodeJSON]
unittests/Futhark/Representation/AST/AttributesTests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Futhark.Representation.AST.AttributesTests ( tests
unittests/Futhark/Representation/ExplicitMemory/IndexFunction/Alg.hs view
@@ -17,7 +17,6 @@ ) where -import Data.Monoid ((<>)) import Data.List hiding (repeat) import Prelude hiding (repeat, mod)
unittests/Language/Futhark/CoreTests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Futhark.CoreTests () where
unittests/Language/Futhark/SyntaxTests.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Language.Futhark.SyntaxTests (tests) where
unittests/futhark_tests.hs view
@@ -1,6 +1,7 @@ module Main (main) where import qualified Language.Futhark.SyntaxTests+import qualified Futhark.BenchTests import qualified Futhark.Representation.AST.Syntax.CoreTests import qualified Futhark.Representation.AST.AttributesTests import qualified Futhark.Representation.ExplicitMemory.IndexFunctionTests@@ -15,6 +16,7 @@ allTests = testGroup "" [ Language.Futhark.SyntaxTests.tests+ , Futhark.BenchTests.tests , Futhark.Representation.AST.AttributesTests.tests , Futhark.Optimise.AlgSimplifyTests.tests , Futhark.Representation.AST.Syntax.CoreTests.tests