diff --git a/docs/man/futhark-autotune.rst b/docs/man/futhark-autotune.rst new file mode 100644 --- /dev/null +++ b/docs/man/futhark-autotune.rst @@ -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)` diff --git a/docs/man/futhark.rst b/docs/man/futhark.rst --- a/docs/man/futhark.rst +++ b/docs/man/futhark.rst @@ -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 ------------------------------ diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/futlib/functional.fut b/futlib/functional.fut --- a/futlib/functional.fut +++ b/futlib/functional.fut @@ -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 diff --git a/futlib/math.fut b/futlib/math.fut --- a/futlib/math.fut +++ b/futlib/math.fut @@ -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 diff --git a/futlib/soacs.fut b/futlib/soacs.fut --- a/futlib/soacs.fut +++ b/futlib/soacs.fut @@ -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`. diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/rts/csharp/scalar.cs b/rts/csharp/scalar.cs --- a/rts/csharp/scalar.cs +++ b/rts/csharp/scalar.cs @@ -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);} diff --git a/rts/python/__init__.py b/rts/python/__init__.py new file mode 100644 --- /dev/null +++ b/rts/python/__init__.py diff --git a/rts/python/scalar.py b/rts/python/scalar.py --- a/rts/python/scalar.py +++ b/rts/python/scalar.py @@ -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. diff --git a/src/Futhark/Analysis/DataDependencies.hs b/src/Futhark/Analysis/DataDependencies.hs --- a/src/Futhark/Analysis/DataDependencies.hs +++ b/src/Futhark/Analysis/DataDependencies.hs @@ -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 diff --git a/src/Futhark/Analysis/HORepresentation/SOAC.hs b/src/Futhark/Analysis/HORepresentation/SOAC.hs --- a/src/Futhark/Analysis/HORepresentation/SOAC.hs +++ b/src/Futhark/Analysis/HORepresentation/SOAC.hs @@ -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. diff --git a/src/Futhark/Analysis/PrimExp.hs b/src/Futhark/Analysis/PrimExp.hs --- a/src/Futhark/Analysis/PrimExp.hs +++ b/src/Futhark/Analysis/PrimExp.hs @@ -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 diff --git a/src/Futhark/Analysis/ScalExp.hs b/src/Futhark/Analysis/ScalExp.hs --- a/src/Futhark/Analysis/ScalExp.hs +++ b/src/Futhark/Analysis/ScalExp.hs @@ -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) diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Bench.hs @@ -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) diff --git a/src/Futhark/Binder/Class.hs b/src/Futhark/Binder/Class.hs --- a/src/Futhark/Binder/Class.hs +++ b/src/Futhark/Binder/Class.hs @@ -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)) diff --git a/src/Futhark/CLI/Autotune.hs b/src/Futhark/CLI/Autotune.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Autotune.hs @@ -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 diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs --- a/src/Futhark/CLI/Bench.hs +++ b/src/Futhark/CLI/Bench.hs @@ -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." diff --git a/src/Futhark/CLI/Doc.hs b/src/Futhark/CLI/Doc.hs --- a/src/Futhark/CLI/Doc.hs +++ b/src/Futhark/CLI/Doc.hs @@ -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 diff --git a/src/Futhark/CLI/Misc.hs b/src/Futhark/CLI/Misc.hs --- a/src/Futhark/CLI/Misc.hs +++ b/src/Futhark/CLI/Misc.hs @@ -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 diff --git a/src/Futhark/CLI/Pkg.hs b/src/Futhark/CLI/Pkg.hs --- a/src/Futhark/CLI/Pkg.hs +++ b/src/Futhark/CLI/Pkg.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs --- a/src/Futhark/CodeGen/Backends/CCUDA.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -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; } diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -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( diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL.hs b/src/Futhark/CodeGen/Backends/CSOpenCL.hs --- a/src/Futhark/CodeGen/Backends/CSOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/CSOpenCL.hs @@ -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" [] diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -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) { diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp.hs b/src/Futhark/CodeGen/Backends/GenericCSharp.hs --- a/src/Futhark/CodeGen/Backends/GenericCSharp.hs +++ b/src/Futhark/CodeGen/Backends/GenericCSharp.hs @@ -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. diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -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 "|" diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL.hs b/src/Futhark/CodeGen/Backends/PyOpenCL.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL.hs @@ -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 = diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs b/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs --- a/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs +++ b/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs @@ -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") |] diff --git a/src/Futhark/CodeGen/ImpCode.hs b/src/Futhark/CodeGen/ImpCode.hs --- a/src/Futhark/CodeGen/ImpCode.hs +++ b/src/Futhark/CodeGen/ImpCode.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpCode/Kernels.hs b/src/Futhark/CodeGen/ImpCode/Kernels.hs --- a/src/Futhark/CodeGen/ImpCode/Kernels.hs +++ b/src/Futhark/CodeGen/ImpCode/Kernels.hs @@ -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]) diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -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 () diff --git a/src/Futhark/CodeGen/ImpGen/Kernels.hs b/src/Futhark/CodeGen/ImpGen/Kernels.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegGenRed.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegGenRed.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegGenRed.hs +++ /dev/null @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs @@ -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" $ diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs @@ -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 diff --git a/src/Futhark/CodeGen/SetDefaultSpace.hs b/src/Futhark/CodeGen/SetDefaultSpace.hs --- a/src/Futhark/CodeGen/SetDefaultSpace.hs +++ b/src/Futhark/CodeGen/SetDefaultSpace.hs @@ -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 diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -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 diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs --- a/src/Futhark/Internalise/Bindings.hs +++ b/src/Futhark/Internalise/Bindings.hs @@ -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 diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -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 diff --git a/src/Futhark/Internalise/Defunctorise.hs b/src/Futhark/Internalise/Defunctorise.hs --- a/src/Futhark/Internalise/Defunctorise.hs +++ b/src/Futhark/Internalise/Defunctorise.hs @@ -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 diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -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 diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs --- a/src/Futhark/Internalise/TypesValues.hs +++ b/src/Futhark/Internalise/TypesValues.hs @@ -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 diff --git a/src/Futhark/Optimise/Fusion.hs b/src/Futhark/Optimise/Fusion.hs --- a/src/Futhark/Optimise/Fusion.hs +++ b/src/Futhark/Optimise/Fusion.hs @@ -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 diff --git a/src/Futhark/Optimise/Fusion/LoopKernel.hs b/src/Futhark/Optimise/Fusion/LoopKernel.hs --- a/src/Futhark/Optimise/Fusion/LoopKernel.hs +++ b/src/Futhark/Optimise/Fusion/LoopKernel.hs @@ -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) diff --git a/src/Futhark/Optimise/InPlaceLowering.hs b/src/Futhark/Optimise/InPlaceLowering.hs --- a/src/Futhark/Optimise/InPlaceLowering.hs +++ b/src/Futhark/Optimise/InPlaceLowering.hs @@ -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 () diff --git a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs --- a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +++ b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs @@ -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. diff --git a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs --- a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +++ b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs @@ -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) diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -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, diff --git a/src/Futhark/Optimise/Simplify/Lore.hs b/src/Futhark/Optimise/Simplify/Lore.hs --- a/src/Futhark/Optimise/Simplify/Lore.hs +++ b/src/Futhark/Optimise/Simplify/Lore.hs @@ -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 diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs --- a/src/Futhark/Optimise/Simplify/Rules.hs +++ b/src/Futhark/Optimise/Simplify/Rules.hs @@ -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 diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -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" =<< diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs --- a/src/Futhark/Pass/ExpandAllocations.hs +++ b/src/Futhark/Pass/ExpandAllocations.hs @@ -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" $ diff --git a/src/Futhark/Pass/ExplicitAllocations.hs b/src/Futhark/Pass/ExplicitAllocations.hs --- a/src/Futhark/Pass/ExplicitAllocations.hs +++ b/src/Futhark/Pass/ExplicitAllocations.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs --- a/src/Futhark/Pass/ExtractKernels.hs +++ b/src/Futhark/Pass/ExtractKernels.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs --- a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs @@ -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] diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs --- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs +++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs @@ -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 = diff --git a/src/Futhark/Pass/ExtractKernels/Distribution.hs b/src/Futhark/Pass/ExtractKernels/Distribution.hs --- a/src/Futhark/Pass/ExtractKernels/Distribution.hs +++ b/src/Futhark/Pass/ExtractKernels/Distribution.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels/Intragroup.hs b/src/Futhark/Pass/ExtractKernels/Intragroup.hs --- a/src/Futhark/Pass/ExtractKernels/Intragroup.hs +++ b/src/Futhark/Pass/ExtractKernels/Intragroup.hs @@ -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) diff --git a/src/Futhark/Pass/KernelBabysitting.hs b/src/Futhark/Pass/KernelBabysitting.hs --- a/src/Futhark/Pass/KernelBabysitting.hs +++ b/src/Futhark/Pass/KernelBabysitting.hs @@ -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 = diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs --- a/src/Futhark/Passes.hs +++ b/src/Futhark/Passes.hs @@ -55,6 +55,7 @@ , babysitKernels , tileLoops , unstream + , performCSE True , simplifyKernels , inPlaceLowering ] diff --git a/src/Futhark/Pkg/Info.hs b/src/Futhark/Pkg/Info.hs --- a/src/Futhark/Pkg/Info.hs +++ b/src/Futhark/Pkg/Info.hs @@ -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 () diff --git a/src/Futhark/Pkg/Solve.hs b/src/Futhark/Pkg/Solve.hs --- a/src/Futhark/Pkg/Solve.hs +++ b/src/Futhark/Pkg/Solve.hs @@ -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 diff --git a/src/Futhark/Pkg/Types.hs b/src/Futhark/Pkg/Types.hs --- a/src/Futhark/Pkg/Types.hs +++ b/src/Futhark/Pkg/Types.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Annotations.hs b/src/Futhark/Representation/AST/Annotations.hs --- a/src/Futhark/Representation/AST/Annotations.hs +++ b/src/Futhark/Representation/AST/Annotations.hs @@ -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 = () diff --git a/src/Futhark/Representation/AST/Attributes.hs b/src/Futhark/Representation/AST/Attributes.hs --- a/src/Futhark/Representation/AST/Attributes.hs +++ b/src/Futhark/Representation/AST/Attributes.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Attributes/Aliases.hs b/src/Futhark/Representation/AST/Attributes/Aliases.hs --- a/src/Futhark/Representation/AST/Attributes/Aliases.hs +++ b/src/Futhark/Representation/AST/Attributes/Aliases.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Attributes/Ranges.hs b/src/Futhark/Representation/AST/Attributes/Ranges.hs --- a/src/Futhark/Representation/AST/Attributes/Ranges.hs +++ b/src/Futhark/Representation/AST/Attributes/Ranges.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Attributes/Reshape.hs b/src/Futhark/Representation/AST/Attributes/Reshape.hs --- a/src/Futhark/Representation/AST/Attributes/Reshape.hs +++ b/src/Futhark/Representation/AST/Attributes/Reshape.hs @@ -179,3 +179,5 @@ sliceSizes [] = [1] sliceSizes (n:ns) = product (n : ns) : sliceSizes ns + +{- HLINT ignore sliceSizes -} diff --git a/src/Futhark/Representation/AST/Attributes/Types.hs b/src/Futhark/Representation/AST/Attributes/Types.hs --- a/src/Futhark/Representation/AST/Attributes/Types.hs +++ b/src/Futhark/Representation/AST/Attributes/Types.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Pretty.hs b/src/Futhark/Representation/AST/Pretty.hs --- a/src/Futhark/Representation/AST/Pretty.hs +++ b/src/Futhark/Representation/AST/Pretty.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Syntax/Core.hs b/src/Futhark/Representation/AST/Syntax/Core.hs --- a/src/Futhark/Representation/AST/Syntax/Core.hs +++ b/src/Futhark/Representation/AST/Syntax/Core.hs @@ -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 diff --git a/src/Futhark/Representation/AST/Traversals.hs b/src/Futhark/Representation/AST/Traversals.hs --- a/src/Futhark/Representation/AST/Traversals.hs +++ b/src/Futhark/Representation/AST/Traversals.hs @@ -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 diff --git a/src/Futhark/Representation/Aliases.hs b/src/Futhark/Representation/Aliases.hs --- a/src/Futhark/Representation/Aliases.hs +++ b/src/Futhark/Representation/Aliases.hs @@ -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 diff --git a/src/Futhark/Representation/ExplicitMemory.hs b/src/Futhark/Representation/ExplicitMemory.hs --- a/src/Futhark/Representation/ExplicitMemory.hs +++ b/src/Futhark/Representation/ExplicitMemory.hs @@ -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] diff --git a/src/Futhark/Representation/Kernels.hs b/src/Futhark/Representation/Kernels.hs --- a/src/Futhark/Representation/Kernels.hs +++ b/src/Futhark/Representation/Kernels.hs @@ -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 diff --git a/src/Futhark/Representation/Kernels/Kernel.hs b/src/Futhark/Representation/Kernels/Kernel.hs --- a/src/Futhark/Representation/Kernels/Kernel.hs +++ b/src/Futhark/Representation/Kernels/Kernel.hs @@ -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 diff --git a/src/Futhark/Representation/Kernels/KernelExp.hs b/src/Futhark/Representation/Kernels/KernelExp.hs deleted file mode 100644 --- a/src/Futhark/Representation/Kernels/KernelExp.hs +++ /dev/null @@ -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 - | 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 diff --git a/src/Futhark/Representation/Kernels/Simplify.hs b/src/Futhark/Representation/Kernels/Simplify.hs --- a/src/Futhark/Representation/Kernels/Simplify.hs +++ b/src/Futhark/Representation/Kernels/Simplify.hs @@ -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 diff --git a/src/Futhark/Representation/Primitive.hs b/src/Futhark/Representation/Primitive.hs --- a/src/Futhark/Representation/Primitive.hs +++ b/src/Futhark/Representation/Primitive.hs @@ -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 diff --git a/src/Futhark/Representation/Ranges.hs b/src/Futhark/Representation/Ranges.hs --- a/src/Futhark/Representation/Ranges.hs +++ b/src/Futhark/Representation/Ranges.hs @@ -34,7 +34,6 @@ import Control.Monad.Identity import Control.Monad.Reader -import Data.Monoid ((<>)) import Data.Foldable import Futhark.Representation.AST.Syntax diff --git a/src/Futhark/Representation/SOACS/SOAC.hs b/src/Futhark/Representation/SOACS/SOAC.hs --- a/src/Futhark/Representation/SOACS/SOAC.hs +++ b/src/Futhark/Representation/SOACS/SOAC.hs @@ -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 + | Hist SubExp [HistOp lore] (Lambda lore) [VName] + -- Hist -- -- 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) => diff --git a/src/Futhark/Representation/SOACS/Simplify.hs b/src/Futhark/Representation/SOACS/Simplify.hs --- a/src/Futhark/Representation/SOACS/Simplify.hs +++ b/src/Futhark/Representation/SOACS/Simplify.hs @@ -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) <- diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -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{} -> "" 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] diff --git a/src/Futhark/Transform/FirstOrderTransform.hs b/src/Futhark/Transform/FirstOrderTransform.hs --- a/src/Futhark/Transform/FirstOrderTransform.hs +++ b/src/Futhark/Transform/FirstOrderTransform.hs @@ -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. diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -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 diff --git a/src/Language/Futhark/Attributes.hs b/src/Language/Futhark/Attributes.hs --- a/src/Language/Futhark/Attributes.hs +++ b/src/Language/Futhark/Attributes.hs @@ -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 diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -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 diff --git a/src/Language/Futhark/Parser/Lexer.x b/src/Language/Futhark/Parser/Lexer.x --- a/src/Language/Futhark/Parser/Lexer.x +++ b/src/Language/Futhark/Parser/Lexer.x @@ -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 -> diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -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 diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -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) diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -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 diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs --- a/src/Language/Futhark/Traversals.hs +++ b/src/Language/Futhark/Traversals.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Monad.hs b/src/Language/Futhark/TypeChecker/Monad.hs --- a/src/Language/Futhark/TypeChecker/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Monad.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker/Unify.hs b/src/Language/Futhark/TypeChecker/Unify.hs --- a/src/Language/Futhark/TypeChecker/Unify.hs +++ b/src/Language/Futhark/TypeChecker/Unify.hs @@ -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 diff --git a/src/futhark.hs b/src/futhark.hs --- a/src/futhark.hs +++ b/src/futhark.hs @@ -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 diff --git a/unittests/Futhark/Analysis/ScalExpTests.hs b/unittests/Futhark/Analysis/ScalExpTests.hs --- a/unittests/Futhark/Analysis/ScalExpTests.hs +++ b/unittests/Futhark/Analysis/ScalExpTests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Futhark.Analysis.ScalExpTests ( tests diff --git a/unittests/Futhark/BenchTests.hs b/unittests/Futhark/BenchTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/BenchTests.hs @@ -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] diff --git a/unittests/Futhark/Representation/AST/AttributesTests.hs b/unittests/Futhark/Representation/AST/AttributesTests.hs --- a/unittests/Futhark/Representation/AST/AttributesTests.hs +++ b/unittests/Futhark/Representation/AST/AttributesTests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Futhark.Representation.AST.AttributesTests ( tests diff --git a/unittests/Futhark/Representation/ExplicitMemory/IndexFunction/Alg.hs b/unittests/Futhark/Representation/ExplicitMemory/IndexFunction/Alg.hs --- a/unittests/Futhark/Representation/ExplicitMemory/IndexFunction/Alg.hs +++ b/unittests/Futhark/Representation/ExplicitMemory/IndexFunction/Alg.hs @@ -17,7 +17,6 @@ ) where -import Data.Monoid ((<>)) import Data.List hiding (repeat) import Prelude hiding (repeat, mod) diff --git a/unittests/Language/Futhark/CoreTests.hs b/unittests/Language/Futhark/CoreTests.hs --- a/unittests/Language/Futhark/CoreTests.hs +++ b/unittests/Language/Futhark/CoreTests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Futhark.CoreTests () where diff --git a/unittests/Language/Futhark/SyntaxTests.hs b/unittests/Language/Futhark/SyntaxTests.hs --- a/unittests/Language/Futhark/SyntaxTests.hs +++ b/unittests/Language/Futhark/SyntaxTests.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Language.Futhark.SyntaxTests (tests) where diff --git a/unittests/futhark_tests.hs b/unittests/futhark_tests.hs --- a/unittests/futhark_tests.hs +++ b/unittests/futhark_tests.hs @@ -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