diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: a75ffbf819d567c2108977d336c20ff7f11963b071dc0d9e581faa2f792dba99 +-- hash: d926568e0952a1cecfa1efa7cf687ddc7cd27d1c642a929d85ca5b0e8465b408 name: futhark -version: 0.8.1 +version: 0.9.1 synopsis: An optimising compiler for a functional, array-oriented language. description: See the website at https://futhark-lang.org category: Language @@ -23,6 +23,8 @@ futlib/prelude.fut futlib/soacs.fut futlib/zip.fut + rts/c/cuda.h + rts/c/free_list.h rts/c/lock.h rts/c/opencl.h rts/c/panic.h @@ -37,7 +39,6 @@ rts/csharp/reader.cs rts/csharp/scalar.cs rts/futhark-doc/style.css - rts/python/__init__.py rts/python/memory.py rts/python/opencl.py rts/python/panic.py @@ -49,6 +50,63 @@ location: https://github.com/diku-dk/futhark library + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists + build-depends: + aeson + , ansi-terminal >=0.6.3.1 + , array >=0.4 + , base >=4 && <5 + , bifunctors >=5.4.2 + , binary >=0.8.3 + , blaze-html >=0.9.0.1 + , bytestring >=0.10.8 + , containers >=0.5 + , data-binary-ieee754 >=0.1 + , directory >=1.3.0.0 + , directory-tree >=0.12.1 + , dlist >=0.6.0.1 + , extra >=1.5.3 + , file-embed >=0.0.9 + , filepath >=1.4.1.1 + , free >=4.12.4 + , gitrev >=1.2.0 + , haskeline + , http-client >=0.5.7.0 + , http-client-tls >=0.3.5.1 + , http-conduit >=2.2.4 + , language-c-quote >=0.12 + , mainland-pretty >=0.6.1 + , markdown >=0.1.16 + , megaparsec >=7.0.1 + , mtl >=2.2.1 + , neat-interpolation >=0.3 + , parallel >=3.2.1.0 + , parser-combinators >=1.0.0 + , process >=1.4.3.0 + , process-extras >=0.7.2 + , random + , raw-strings-qq >=1.1 + , regex-tdfa >=1.2 + , srcloc >=0.4 + , template-haskell >=2.11.1 + , temporary + , text >=1.2.2.2 + , th-lift-instances >=0.1.11 + , time >=1.6.0.1 + , transformers >=0.3 + , 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 + if !impl(ghc >= 8.0) + build-depends: + semigroups ==0.18.* exposed-modules: Futhark.Actions Futhark.Analysis.AlgSimplify @@ -69,6 +127,25 @@ Futhark.Analysis.UsageTable Futhark.Binder Futhark.Binder.Class + Futhark.CLI.Bench + Futhark.CLI.C + Futhark.CLI.CSharp + Futhark.CLI.CSOpenCL + Futhark.CLI.CUDA + Futhark.CLI.Datacmp + Futhark.CLI.Dataset + Futhark.CLI.Dev + Futhark.CLI.Doc + Futhark.CLI.Misc + Futhark.CLI.OpenCL + Futhark.CLI.Pkg + Futhark.CLI.PyOpenCL + Futhark.CLI.Python + Futhark.CLI.REPL + Futhark.CLI.Run + Futhark.CLI.Test + Futhark.CodeGen.Backends.CCUDA + Futhark.CodeGen.Backends.CCUDA.Boilerplate Futhark.CodeGen.Backends.COpenCL Futhark.CodeGen.Backends.COpenCL.Boilerplate Futhark.CodeGen.Backends.CSOpenCL @@ -94,7 +171,10 @@ Futhark.CodeGen.ImpCode.OpenCL Futhark.CodeGen.ImpCode.Sequential Futhark.CodeGen.ImpGen + Futhark.CodeGen.ImpGen.CUDA Futhark.CodeGen.ImpGen.Kernels + Futhark.CodeGen.ImpGen.Kernels.Base + Futhark.CodeGen.ImpGen.Kernels.SegRed Futhark.CodeGen.ImpGen.Kernels.ToOpenCL Futhark.CodeGen.ImpGen.Kernels.Transpose Futhark.CodeGen.ImpGen.OpenCL @@ -177,6 +257,7 @@ Futhark.Pass.ExtractKernels.ISRWIM Futhark.Pass.ExtractKernels.Kernelise Futhark.Pass.ExtractKernels.Segmented + Futhark.Pass.ExtractKernels.Split Futhark.Pass.FirstOrderTransform Futhark.Pass.KernelBabysitting Futhark.Pass.ResolveAssertions @@ -254,65 +335,10 @@ Language.Futhark.Parser.Parser Language.Futhark.Parser.Lexer Paths_futhark - hs-source-dirs: - src - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists - build-depends: - ansi-terminal >=0.6.3.1 - , array >=0.4 - , base >=4 && <5 - , bifunctors >=5.4.2 - , binary >=0.8.3 - , blaze-html >=0.9.0.1 - , bytestring >=0.10.8 - , containers >=0.5 - , data-binary-ieee754 >=0.1 - , directory >=1.3.0.0 - , directory-tree >=0.12.1 - , dlist >=0.6.0.1 - , extra >=1.5.3 - , file-embed >=0.0.9 - , filepath >=1.4.1.1 - , free >=4.12.4 - , gitrev >=1.2.0 - , http-client >=0.5.7.0 - , http-client-tls >=0.3.5.1 - , http-conduit >=2.2.4 - , language-c-quote >=0.12 - , mainland-pretty >=0.6.1 - , markdown >=0.1.16 - , megaparsec >=7.0.1 - , mtl >=2.2.1 - , neat-interpolation >=0.3 - , parallel >=3.2.1.0 - , parser-combinators >=1.0.0 - , process >=1.4.3.0 - , process-extras >=0.7.2 - , raw-strings-qq >=1.1 - , regex-tdfa >=1.2 - , srcloc >=0.4 - , template-haskell >=2.11.1 - , text >=1.2.2.2 - , th-lift-instances >=0.1.11 - , time >=1.6.0.1 - , transformers >=0.3 - , 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 - if !impl(ghc >= 8.0) - build-depends: - semigroups ==0.18.* default-language: Haskell2010 executable futhark main-is: src/futhark.hs - other-modules: - Paths_futhark ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" build-depends: aeson @@ -334,6 +360,7 @@ , free >=4.12.4 , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -365,13 +392,15 @@ if !impl(ghc >= 8.0) build-depends: semigroups ==0.18.* + other-modules: + Paths_futhark default-language: Haskell2010 executable futhark-bench - main-is: src/futhark-bench.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -390,8 +419,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -426,10 +455,10 @@ default-language: Haskell2010 executable futhark-c - main-is: src/futhark-c.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -448,8 +477,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -484,10 +513,10 @@ default-language: Haskell2010 executable futhark-cs - main-is: src/futhark-cs.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -506,8 +535,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -542,10 +571,10 @@ default-language: Haskell2010 executable futhark-csopencl - main-is: src/futhark-csopencl.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -564,8 +593,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -600,10 +629,10 @@ default-language: Haskell2010 executable futhark-dataset - main-is: src/futhark-dataset.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -622,8 +651,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -658,10 +687,10 @@ default-language: Haskell2010 executable futhark-doc - main-is: src/futhark-doc.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -680,8 +709,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -716,10 +745,10 @@ default-language: Haskell2010 executable futhark-opencl - main-is: src/futhark-opencl.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -738,8 +767,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -774,10 +803,10 @@ default-language: Haskell2010 executable futhark-pkg - main-is: src/futhark-pkg.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -796,8 +825,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -832,10 +861,10 @@ default-language: Haskell2010 executable futhark-py - main-is: src/futhark-py.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -854,8 +883,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -890,10 +919,10 @@ default-language: Haskell2010 executable futhark-pyopencl - main-is: src/futhark-pyopencl.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -912,8 +941,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -948,10 +977,10 @@ default-language: Haskell2010 executable futhark-test - main-is: src/futhark-test.hs + main-is: src/wrapper.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: aeson , ansi-terminal >=0.6.3.1 @@ -970,8 +999,8 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -1009,9 +1038,10 @@ main-is: src/futharki.hs other-modules: Paths_futhark - ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists -threaded -rtsopts "-with-rtsopts=-N -qg" + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: - ansi-terminal >=0.6.3.1 + aeson + , ansi-terminal >=0.6.3.1 , array >=0.4 , base >=4 && <5 , bifunctors >=5.4.2 @@ -1027,7 +1057,6 @@ , file-embed >=0.0.9 , filepath >=1.4.1.1 , free >=4.12.4 - , futhark , gitrev >=1.2.0 , haskeline , http-client >=0.5.7.0 @@ -1043,10 +1072,12 @@ , parser-combinators >=1.0.0 , process >=1.4.3.0 , process-extras >=0.7.2 + , random , raw-strings-qq >=1.1 , regex-tdfa >=1.2 , srcloc >=0.4 , template-haskell >=2.11.1 + , temporary , text >=1.2.2.2 , th-lift-instances >=0.1.11 , time >=1.6.0.1 @@ -1064,25 +1095,13 @@ test-suite unit type: exitcode-stdio-1.0 main-is: futhark_tests.hs - other-modules: - Futhark.Analysis.ScalExpTests - Futhark.Optimise.AlgSimplifyTests - Futhark.Pkg.SolveTests - Futhark.Representation.AST.Attributes.RearrangeTests - Futhark.Representation.AST.Attributes.ReshapeTests - Futhark.Representation.AST.AttributesTests - Futhark.Representation.AST.Syntax.CoreTests - Futhark.Representation.AST.SyntaxTests - Futhark.Representation.PrimitiveTests - Language.Futhark.CoreTests - Language.Futhark.SyntaxTests - Paths_futhark hs-source-dirs: unittests ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists build-depends: HUnit , QuickCheck >=2.8 + , aeson , ansi-terminal >=0.6.3.1 , array >=0.4 , base >=4 && <5 @@ -1101,6 +1120,7 @@ , free >=4.12.4 , futhark , gitrev >=1.2.0 + , haskeline , http-client >=0.5.7.0 , http-client-tls >=0.3.5.1 , http-conduit >=2.2.4 @@ -1114,6 +1134,7 @@ , parser-combinators >=1.0.0 , process >=1.4.3.0 , process-extras >=0.7.2 + , random , raw-strings-qq >=1.1 , regex-tdfa >=1.2 , srcloc >=0.4 @@ -1121,6 +1142,7 @@ , tasty-hunit , tasty-quickcheck , template-haskell >=2.11.1 + , temporary , text >=1.2.2.2 , th-lift-instances >=0.1.11 , time >=1.6.0.1 @@ -1133,4 +1155,17 @@ if !impl(ghc >= 8.0) build-depends: semigroups ==0.18.* + other-modules: + Futhark.Analysis.ScalExpTests + Futhark.Optimise.AlgSimplifyTests + Futhark.Pkg.SolveTests + Futhark.Representation.AST.Attributes.RearrangeTests + Futhark.Representation.AST.Attributes.ReshapeTests + Futhark.Representation.AST.AttributesTests + Futhark.Representation.AST.Syntax.CoreTests + Futhark.Representation.AST.SyntaxTests + Futhark.Representation.PrimitiveTests + Language.Futhark.CoreTests + Language.Futhark.SyntaxTests + Paths_futhark default-language: Haskell2010 diff --git a/rts/c/cuda.h b/rts/c/cuda.h new file mode 100644 --- /dev/null +++ b/rts/c/cuda.h @@ -0,0 +1,535 @@ +/* Simple CUDA runtime framework */ + +#define CUDA_SUCCEED(x) cuda_api_succeed(x, #x, __FILE__, __LINE__) +#define NVRTC_SUCCEED(x) nvrtc_api_succeed(x, #x, __FILE__, __LINE__) + +static inline void cuda_api_succeed(CUresult res, const char *call, + const char *file, int line) +{ + if (res != CUDA_SUCCESS) { + const char *err_str; + cuGetErrorString(res, &err_str); + if (err_str == NULL) { err_str = "Unknown"; } + panic(-1, "%s:%d: CUDA call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } +} + +static inline void nvrtc_api_succeed(nvrtcResult res, const char *call, + const char *file, int line) +{ + if (res != NVRTC_SUCCESS) { + const char *err_str = nvrtcGetErrorString(res); + panic(-1, "%s:%d: NVRTC call\n %s\nfailed with error code %d (%s)\n", + file, line, call, res, err_str); + } +} + +struct cuda_config { + int debugging; + int logging; + const char *preferred_device; + + const char *dump_program_to; + const char *load_program_from; + + const char *dump_ptx_to; + const char *load_ptx_from; + + size_t default_block_size; + size_t default_grid_size; + size_t default_tile_size; + size_t default_threshold; + + int default_block_size_changed; + int default_grid_size_changed; + int default_tile_size_changed; + + int num_sizes; + const char **size_names; + const char **size_vars; + size_t *size_values; + const char **size_classes; +}; + +void cuda_config_init(struct cuda_config *cfg, + int num_sizes, + const char *size_names[], + const char *size_vars[], + size_t *size_values, + const char *size_classes[]) +{ + cfg->debugging = 0; + cfg->logging = 0; + cfg->preferred_device = ""; + + cfg->dump_program_to = NULL; + cfg->load_program_from = NULL; + + cfg->dump_ptx_to = NULL; + cfg->load_ptx_from = NULL; + + cfg->default_block_size = 256; + cfg->default_grid_size = 128; + cfg->default_tile_size = 32; + cfg->default_threshold = 32*1024; + + cfg->default_block_size_changed = 0; + cfg->default_grid_size_changed = 0; + cfg->default_tile_size_changed = 0; + + cfg->num_sizes = num_sizes; + cfg->size_names = size_names; + cfg->size_vars = size_vars; + cfg->size_values = size_values; + cfg->size_classes = size_classes; +} + +struct cuda_context { + CUdevice dev; + CUcontext cu_ctx; + CUmodule module; + + struct cuda_config cfg; + + struct free_list free_list; + + size_t max_block_size; + size_t max_grid_size; + size_t max_tile_size; + size_t max_threshold; + + size_t lockstep_width; +}; + +#define CU_DEV_ATTR(x) (CU_DEVICE_ATTRIBUTE_##x) +#define device_query(dev,attrib) _device_query(dev, CU_DEV_ATTR(attrib)) +static int _device_query(CUdevice dev, CUdevice_attribute attrib) +{ + int val; + CUDA_SUCCEED(cuDeviceGetAttribute(&val, attrib, dev)); + return val; +} + +#define CU_FUN_ATTR(x) (CU_FUNC_ATTRIBUTE_##x) +#define function_query(fn,attrib) _function_query(dev, CU_FUN_ATTR(attrib)) +static int _function_query(CUfunction dev, CUfunction_attribute attrib) +{ + int val; + CUDA_SUCCEED(cuFuncGetAttribute(&val, attrib, dev)); + return val; +} + +void set_preferred_device(struct cuda_config *cfg, const char *s) +{ + cfg->preferred_device = s; +} + +static int cuda_device_setup(struct cuda_context *ctx) +{ + char name[256]; + int count, chosen = -1, best_cc = -1; + int cc_major_best, cc_minor_best; + int cc_major, cc_minor; + CUdevice dev; + + CUDA_SUCCEED(cuDeviceGetCount(&count)); + if (count == 0) { return 1; } + + // XXX: Current device selection policy is to choose the device with the + // highest compute capability (if no preferred device is set). + // This should maybe be changed, since greater compute capability is not + // necessarily an indicator of better performance. + for (int i = 0; i < count; i++) { + CUDA_SUCCEED(cuDeviceGet(&dev, i)); + + cc_major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); + cc_minor = device_query(dev, COMPUTE_CAPABILITY_MINOR); + + CUDA_SUCCEED(cuDeviceGetName(name, sizeof(name)/sizeof(name[0]) - 1, dev)); + name[sizeof(name)/sizeof(name[0])] = 0; + + if (ctx->cfg.debugging) { + fprintf(stderr, "Device #%d: name=\"%s\", compute capability=%d.%d\n", + i, name, cc_major, cc_minor); + } + + if (device_query(dev, COMPUTE_MODE) == CU_COMPUTEMODE_PROHIBITED) { + if (ctx->cfg.debugging) { + fprintf(stderr, "Device #%d is compute-prohibited, ignoring\n", i); + } + continue; + } + + if (best_cc == -1 || cc_major > cc_major_best || + (cc_major == cc_major_best && cc_minor > cc_minor_best)) { + best_cc = i; + cc_major_best = cc_major; + cc_minor_best = cc_minor; + } + + if (chosen == -1 && strstr(name, ctx->cfg.preferred_device) == name) { + chosen = i; + } + } + + if (chosen == -1) { chosen = best_cc; } + if (chosen == -1) { return 1; } + + if (ctx->cfg.debugging) { + fprintf(stderr, "Using device #%d\n", chosen); + } + + CUDA_SUCCEED(cuDeviceGet(&ctx->dev, chosen)); + return 0; +} + +static char *concat_fragments(const char *src_fragments[]) +{ + size_t src_len = 0; + const char **p; + + for (p = src_fragments; *p; p++) { + src_len += strlen(*p); + } + + char *src = malloc(src_len + 1); + size_t n = 0; + for (p = src_fragments; *p; p++) { + strcpy(src + n, *p); + n += strlen(*p); + } + + return src; +} + +static const char *cuda_nvrtc_get_arch(CUdevice dev) +{ + struct { + int major; + int minor; + const char *arch_str; + } static const x[] = { + { 3, 0, "compute_30" }, + { 3, 2, "compute_32" }, + { 3, 5, "compute_35" }, + { 3, 7, "compute_37" }, + { 5, 0, "compute_50" }, + { 5, 2, "compute_52" }, + { 5, 3, "compute_53" }, + { 6, 0, "compute_60" }, + { 6, 1, "compute_61" }, + { 6, 2, "compute_62" }, + { 7, 0, "compute_70" }, + { 7, 2, "compute_72" } + }; + + int major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); + int minor = device_query(dev, COMPUTE_CAPABILITY_MINOR); + + int chosen = -1; + for (int i = 0; i < sizeof(x)/sizeof(x[0]); i++) { + if (x[i].major < major || (x[i].major == major && x[i].minor <= minor)) { + chosen = i; + } else { + break; + } + } + + if (chosen == -1) { + panic(-1, "Unsupported compute capability %d.%d\n", major, minor); + } + return x[chosen].arch_str; +} + +static char *cuda_nvrtc_build(struct cuda_context *ctx, const char *src) +{ + nvrtcProgram prog; + NVRTC_SUCCEED(nvrtcCreateProgram(&prog, src, "futhark-cuda", 0, NULL, NULL)); + + size_t n_opts, i = 0, i_dyn, n_opts_alloc = 20 + ctx->cfg.num_sizes; + const char **opts = malloc(n_opts_alloc * sizeof(const char *)); + opts[i++] = "-arch"; + opts[i++] = cuda_nvrtc_get_arch(ctx->dev); + opts[i++] = "-default-device"; + if (ctx->cfg.debugging) { + opts[i++] = "-G"; + opts[i++] = "-lineinfo"; + } else { + opts[i++] = "--disable-warnings"; + } + i_dyn = i; + for (size_t j = 0; j < ctx->cfg.num_sizes; j++) { + opts[i++] = msgprintf("-D%s=%zu", ctx->cfg.size_vars[j], + ctx->cfg.size_values[j]); + } + opts[i++] = msgprintf("-DLOCKSTEP_WIDTH=%zu", ctx->lockstep_width); + opts[i++] = msgprintf("-DMAX_THREADS_PER_BLOCK=%zu", ctx->max_block_size); + n_opts = i; + + if (ctx->cfg.debugging) { + fprintf(stderr, "NVRTC compile options:\n"); + for (size_t j = 0; j < n_opts; j++) { + fprintf(stderr, "\t%s\n", opts[j]); + } + fprintf(stderr, "\n"); + } + + nvrtcResult res = nvrtcCompileProgram(prog, n_opts, opts); + if (res != NVRTC_SUCCESS) { + size_t log_size; + if (nvrtcGetProgramLogSize(prog, &log_size) == NVRTC_SUCCESS) { + char *log = malloc(log_size); + if (nvrtcGetProgramLog(prog, log) == NVRTC_SUCCESS) { + fprintf(stderr,"Compilation log:\n%s\n", log); + } + free(log); + } + NVRTC_SUCCEED(res); + } + + for (i = i_dyn; i < n_opts; i++) { free((char *)opts[i]); } + free(opts); + + char *ptx; + size_t ptx_size; + NVRTC_SUCCEED(nvrtcGetPTXSize(prog, &ptx_size)); + ptx = malloc(ptx_size); + NVRTC_SUCCEED(nvrtcGetPTX(prog, ptx)); + + NVRTC_SUCCEED(nvrtcDestroyProgram(&prog)); + + return ptx; +} + +static void cuda_size_setup(struct cuda_context *ctx) +{ + if (ctx->cfg.default_block_size > ctx->max_block_size) { + if (ctx->cfg.default_block_size_changed) { + fprintf(stderr, + "Note: Device limits default block size to %zu (down from %zu).\n", + ctx->max_block_size, ctx->cfg.default_block_size); + } + ctx->cfg.default_block_size = ctx->max_block_size; + } + if (ctx->cfg.default_grid_size > ctx->max_grid_size) { + if (ctx->cfg.default_grid_size_changed) { + fprintf(stderr, + "Note: Device limits default grid size to %zu (down from %zu).\n", + ctx->max_grid_size, ctx->cfg.default_grid_size); + } + ctx->cfg.default_grid_size = ctx->max_grid_size; + } + if (ctx->cfg.default_tile_size > ctx->max_tile_size) { + if (ctx->cfg.default_tile_size_changed) { + fprintf(stderr, + "Note: Device limits default tile size to %zu (down from %zu).\n", + ctx->max_tile_size, ctx->cfg.default_tile_size); + } + ctx->cfg.default_tile_size = ctx->max_tile_size; + } + + for (int i = 0; i < ctx->cfg.num_sizes; i++) { + const char *size_class, *size_name; + size_t *size_value, max_value, default_value; + + size_class = ctx->cfg.size_classes[i]; + size_value = &ctx->cfg.size_values[i]; + size_name = ctx->cfg.size_names[i]; + + if (strstr(size_class, "group_size") == size_class) { + max_value = ctx->max_block_size; + default_value = ctx->cfg.default_block_size; + } else if (strstr(size_class, "num_groups") == size_class) { + max_value = ctx->max_grid_size; + default_value = ctx->cfg.default_grid_size; + } else if (strstr(size_class, "tile_size") == size_class) { + max_value = ctx->max_tile_size; + default_value = ctx->cfg.default_tile_size; + } else if (strstr(size_class, "threshold") == size_class) { + max_value = ctx->max_threshold; + default_value = ctx->cfg.default_threshold; + } else { + panic(1, "Unknown size class for size '%s': %s\n", size_name, size_class); + } + + if (*size_value == 0) { + *size_value = default_value; + } else if (max_value > 0 && *size_value > max_value) { + fprintf(stderr, "Note: Device limits %zu to %zu (down from %zu)\n", + size_name, max_value, *size_value); + *size_value = max_value; + } + } +} + +static void dump_string_to_file(const char *file, const char *buf) +{ + FILE *f = fopen(file, "w"); + assert(f != NULL); + assert(fputs(buf, f) != EOF); + assert(fclose(f) == 0); +} + +static void load_string_from_file(const char *file, char **obuf, size_t *olen) +{ + char *buf; + size_t len; + FILE *f = fopen(file, "r"); + + assert(f != NULL); + assert(fseek(f, 0, SEEK_END) == 0); + len = ftell(f); + assert(fseek(f, 0, SEEK_SET) == 0); + + buf = malloc(len + 1); + assert(fread(buf, 1, len, f) == len); + buf[len] = 0; + *obuf = buf; + if (olen != NULL) { + *olen = len; + } + + assert(fclose(f) == 0); +} + +static void cuda_module_setup(struct cuda_context *ctx, + const char *src_fragments[]) +{ + char *ptx = NULL, *src = NULL; + + if (ctx->cfg.load_ptx_from == NULL && ctx->cfg.load_program_from == NULL) { + src = concat_fragments(src_fragments); + ptx = cuda_nvrtc_build(ctx, src); + } else if (ctx->cfg.load_ptx_from == NULL) { + load_string_from_file(ctx->cfg.load_program_from, &src, NULL); + ptx = cuda_nvrtc_build(ctx, src); + } else { + if (ctx->cfg.load_program_from != NULL) { + fprintf(stderr, + "WARNING: Loading PTX from %s instead of C code from %s\n", + ctx->cfg.load_ptx_from, ctx->cfg.load_program_from); + } + + load_string_from_file(ctx->cfg.load_ptx_from, &ptx, NULL); + } + + if (ctx->cfg.dump_program_to != NULL) { + if (src == NULL) { + src = concat_fragments(src_fragments); + } + dump_string_to_file(ctx->cfg.dump_program_to, src); + } + if (ctx->cfg.dump_ptx_to != NULL) { + dump_string_to_file(ctx->cfg.dump_ptx_to, ptx); + } + + CUDA_SUCCEED(cuModuleLoadData(&ctx->module, ptx)); + + free(ptx); + if (src != NULL) { + free(src); + } +} + +void cuda_setup(struct cuda_context *ctx, const char *src_fragments[]) +{ + CUDA_SUCCEED(cuInit(0)); + + if (cuda_device_setup(ctx) != 0) { + panic(-1, "No suitable CUDA device found.\n"); + } + CUDA_SUCCEED(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev)); + + free_list_init(&ctx->free_list); + + ctx->max_block_size = device_query(ctx->dev, MAX_THREADS_PER_BLOCK); + ctx->max_grid_size = device_query(ctx->dev, MAX_GRID_DIM_X); + ctx->max_tile_size = sqrt(ctx->max_block_size); + ctx->max_threshold = 0; + ctx->lockstep_width = device_query(ctx->dev, WARP_SIZE); + + cuda_size_setup(ctx); + cuda_module_setup(ctx, src_fragments); +} + +CUresult cuda_free_all(struct cuda_context *ctx); + +void cuda_cleanup(struct cuda_context *ctx) +{ + CUDA_SUCCEED(cuda_free_all(ctx)); + CUDA_SUCCEED(cuModuleUnload(ctx->module)); + CUDA_SUCCEED(cuCtxDestroy(ctx->cu_ctx)); +} + +CUresult cuda_alloc(struct cuda_context *ctx, size_t min_size, + const char *tag, CUdeviceptr *mem_out) +{ + if (min_size < sizeof(int)) { + min_size = sizeof(int); + } + + size_t size; + if (free_list_find(&ctx->free_list, tag, &size, mem_out) == 0) { + if (size >= min_size) { + return CUDA_SUCCESS; + } else { + CUresult res = cuMemFree(*mem_out); + if (res != CUDA_SUCCESS) { + return res; + } + } + } + + CUresult res = cuMemAlloc(mem_out, min_size); + while (res == CUDA_ERROR_OUT_OF_MEMORY) { + CUdeviceptr mem; + if (free_list_first(&ctx->free_list, &mem) == 0) { + res = cuMemFree(mem); + if (res != CUDA_SUCCESS) { + return res; + } + } else { + break; + } + res = cuMemAlloc(mem_out, min_size); + } + + return res; +} + +CUresult cuda_free(struct cuda_context *ctx, CUdeviceptr mem, + const char *tag) +{ + size_t size; + CUdeviceptr existing_mem; + + // If there is already a block with this tag, then remove it. + if (free_list_find(&ctx->free_list, tag, &size, &existing_mem) == 0) { + CUresult res = cuMemFree(existing_mem); + if (res != CUDA_SUCCESS) { + return res; + } + } + + CUresult res = cuMemGetAddressRange(NULL, &size, mem); + if (res == CUDA_SUCCESS) { + free_list_insert(&ctx->free_list, size, mem, tag); + } + + return res; +} + +CUresult cuda_free_all(struct cuda_context *ctx) { + CUdeviceptr mem; + free_list_pack(&ctx->free_list); + while (free_list_first(&ctx->free_list, &mem) == 0) { + CUresult res = cuMemFree(mem); + if (res != CUDA_SUCCESS) { + return res; + } + } + + return CUDA_SUCCESS; +} + diff --git a/rts/c/free_list.h b/rts/c/free_list.h new file mode 100644 --- /dev/null +++ b/rts/c/free_list.h @@ -0,0 +1,110 @@ +/* Free list management */ + +/* An entry in the free list. May be invalid, to avoid having to + deallocate entries as soon as they are removed. There is also a + tag, to help with memory reuse. */ +struct free_list_entry { + size_t size; + fl_mem_t mem; + const char *tag; + unsigned char valid; +}; + +struct free_list { + struct free_list_entry *entries; // Pointer to entries. + int capacity; // Number of entries. + int used; // Number of valid entries. +}; + +void free_list_init(struct free_list *l) { + l->capacity = 30; // Picked arbitrarily. + l->used = 0; + l->entries = malloc(sizeof(struct free_list_entry) * l->capacity); + for (int i = 0; i < l->capacity; i++) { + l->entries[i].valid = 0; + } +} + +/* Remove invalid entries from the free list. */ +void free_list_pack(struct free_list *l) { + int p = 0; + for (int i = 0; i < l->capacity; i++) { + if (l->entries[i].valid) { + l->entries[p] = l->entries[i]; + p++; + } + } + // Now p == l->used. + l->entries = realloc(l->entries, l->used * sizeof(struct free_list_entry)); + l->capacity = l->used; +} + +void free_list_destroy(struct free_list *l) { + assert(l->used == 0); + free(l->entries); +} + +int free_list_find_invalid(struct free_list *l) { + int i; + for (i = 0; i < l->capacity; i++) { + if (!l->entries[i].valid) { + break; + } + } + return i; +} + +void free_list_insert(struct free_list *l, size_t size, fl_mem_t mem, const char *tag) { + int i = free_list_find_invalid(l); + + if (i == l->capacity) { + // List is full; so we have to grow it. + int new_capacity = l->capacity * 2 * sizeof(struct free_list_entry); + l->entries = realloc(l->entries, new_capacity); + for (int j = 0; j < l->capacity; j++) { + l->entries[j+l->capacity].valid = 0; + } + l->capacity *= 2; + } + + // Now 'i' points to the first invalid entry. + l->entries[i].valid = 1; + l->entries[i].size = size; + l->entries[i].mem = mem; + l->entries[i].tag = tag; + + l->used++; +} + +/* Find and remove a memory block of at least the desired size and + tag. Returns 0 on success. */ +int free_list_find(struct free_list *l, const char *tag, size_t *size_out, fl_mem_t *mem_out) { + int i; + for (i = 0; i < l->capacity; i++) { + if (l->entries[i].valid && l->entries[i].tag == tag) { + l->entries[i].valid = 0; + *size_out = l->entries[i].size; + *mem_out = l->entries[i].mem; + l->used--; + return 0; + } + } + + return 1; +} + +/* Remove the first block in the free list. Returns 0 if a block was + removed, and nonzero if the free list was already empty. */ +int free_list_first(struct free_list *l, fl_mem_t *mem_out) { + for (int i = 0; i < l->capacity; i++) { + if (l->entries[i].valid) { + l->entries[i].valid = 0; + *mem_out = l->entries[i].mem; + l->used--; + return 0; + } + } + + return 1; +} + diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.h @@ -1,15 +1,5 @@ /* The simple OpenCL runtime framework used by Futhark. */ -#define CL_USE_DEPRECATED_OPENCL_1_2_APIS - -#define CL_SILENCE_DEPRECATION // For macOS. - -#ifdef __APPLE__ - #include -#else - #include -#endif - #define OPENCL_SUCCEED_FATAL(e) opencl_succeed_fatal(e, #e, __FILE__, __LINE__) #define OPENCL_SUCCEED_NONFATAL(e) opencl_succeed_nonfatal(e, #e, __FILE__, __LINE__) // Take care not to override an existing error. @@ -40,6 +30,8 @@ const char* dump_program_to; const char* load_program_from; + const char* dump_binary_to; + const char* load_binary_from; size_t default_group_size; size_t default_num_groups; @@ -51,17 +43,17 @@ int num_sizes; const char **size_names; + const char **size_vars; size_t *size_values; const char **size_classes; - const char **size_entry_points; }; void opencl_config_init(struct opencl_config *cfg, int num_sizes, const char *size_names[], + const char *size_vars[], size_t *size_values, - const char *size_classes[], - const char *size_entry_points[]) { + const char *size_classes[]) { cfg->debugging = 0; cfg->logging = 0; cfg->preferred_device_num = 0; @@ -69,10 +61,16 @@ cfg->preferred_device = ""; cfg->dump_program_to = NULL; cfg->load_program_from = NULL; + cfg->dump_binary_to = NULL; + cfg->load_binary_from = NULL; - cfg->default_group_size = 256; - cfg->default_num_groups = 128; - cfg->default_tile_size = 32; + // The following are dummy sizes that mean the concrete defaults + // will be set during initialisation via hardware-inspection-based + // heuristics. + cfg->default_group_size = 0; + cfg->default_num_groups = 0; + cfg->default_tile_size = 0; + cfg->default_threshold = 32*1024; cfg->default_group_size_changed = 0; @@ -80,119 +78,11 @@ cfg->num_sizes = num_sizes; cfg->size_names = size_names; + cfg->size_vars = size_vars; cfg->size_values = size_values; cfg->size_classes = size_classes; - cfg->size_entry_points = size_entry_points; } -/* An entry in the free list. May be invalid, to avoid having to - deallocate entries as soon as they are removed. There is also a - tag, to help with memory reuse. */ -struct opencl_free_list_entry { - size_t size; - cl_mem mem; - const char *tag; - unsigned char valid; -}; - -struct opencl_free_list { - struct opencl_free_list_entry *entries; // Pointer to entries. - int capacity; // Number of entries. - int used; // Number of valid entries. -}; - -void free_list_init(struct opencl_free_list *l) { - l->capacity = 30; // Picked arbitrarily. - l->used = 0; - l->entries = malloc(sizeof(struct opencl_free_list_entry) * l->capacity); - for (int i = 0; i < l->capacity; i++) { - l->entries[i].valid = 0; - } -} - -/* Remove invalid entries from the free list. */ -void free_list_pack(struct opencl_free_list *l) { - int p = 0; - for (int i = 0; i < l->capacity; i++) { - if (l->entries[i].valid) { - l->entries[p] = l->entries[i]; - p++; - } - } - // Now p == l->used. - l->entries = realloc(l->entries, l->used * sizeof(struct opencl_free_list_entry)); - l->capacity = l->used; -} - -void free_list_destroy(struct opencl_free_list *l) { - assert(l->used == 0); - free(l->entries); -} - -int free_list_find_invalid(struct opencl_free_list *l) { - int i; - for (i = 0; i < l->capacity; i++) { - if (!l->entries[i].valid) { - break; - } - } - return i; -} - -void free_list_insert(struct opencl_free_list *l, size_t size, cl_mem mem, const char *tag) { - int i = free_list_find_invalid(l); - - if (i == l->capacity) { - // List is full; so we have to grow it. - int new_capacity = l->capacity * 2 * sizeof(struct opencl_free_list_entry); - l->entries = realloc(l->entries, new_capacity); - for (int j = 0; j < l->capacity; j++) { - l->entries[j+l->capacity].valid = 0; - } - l->capacity *= 2; - } - - // Now 'i' points to the first invalid entry. - l->entries[i].valid = 1; - l->entries[i].size = size; - l->entries[i].mem = mem; - l->entries[i].tag = tag; - - l->used++; -} - -/* Find and remove a memory block of at least the desired size and - tag. Returns 0 on success. */ -int free_list_find(struct opencl_free_list *l, const char *tag, size_t *size_out, cl_mem *mem_out) { - int i; - for (i = 0; i < l->capacity; i++) { - if (l->entries[i].valid && l->entries[i].tag == tag) { - l->entries[i].valid = 0; - *size_out = l->entries[i].size; - *mem_out = l->entries[i].mem; - l->used--; - return 0; - } - } - - return 1; -} - -/* Remove the first block in the free list. Returns 0 if a block was - removed, and nonzero if the free list was already empty. */ -int free_list_first(struct opencl_free_list *l, cl_mem *mem_out) { - for (int i = 0; i < l->capacity; i++) { - if (l->entries[i].valid) { - l->entries[i].valid = 0; - *mem_out = l->entries[i].mem; - l->used--; - return 0; - } - } - - return 1; -} - struct opencl_context { cl_device_id device; cl_context ctx; @@ -200,7 +90,7 @@ struct opencl_config cfg; - struct opencl_free_list free_list; + struct free_list free_list; size_t max_group_size; size_t max_num_groups; @@ -235,6 +125,30 @@ return copy; } +// Read a file into a NUL-terminated string; returns NULL on error. +static char* slurp_file(const char *filename, size_t *size) { + char *s; + FILE *f = fopen(filename, "rb"); // To avoid Windows messing with linebreaks. + if (f == NULL) return NULL; + fseek(f, 0, SEEK_END); + size_t src_size = ftell(f); + fseek(f, 0, SEEK_SET); + s = (char*) malloc(src_size + 1); + if (fread(s, 1, src_size, f) != src_size) { + free(s); + s = NULL; + } else { + s[src_size] = '\0'; + } + fclose(f); + + if (size) { + *size = src_size; + } + + return s; +} + static const char* opencl_error_string(unsigned int err) { switch (err) { @@ -575,6 +489,9 @@ size_t max_tile_size = sqrt(max_group_size); + // Make sure this function is defined. + post_opencl_setup(ctx, &device_option); + if (max_group_size < ctx->cfg.default_group_size) { if (ctx->cfg.default_group_size_changed) { fprintf(stderr, "Note: Device limits default group size to %zu (down from %zu).\n", @@ -626,9 +543,6 @@ } } - // Make sure this function is defined. - post_opencl_setup(ctx, &device_option); - if (ctx->lockstep_width == 0) { ctx->lockstep_width = 1; } @@ -644,14 +558,8 @@ // Maybe we have to read OpenCL source from somewhere else (used for debugging). if (ctx->cfg.load_program_from != NULL) { - FILE *f = fopen(ctx->cfg.load_program_from, "r"); - assert(f != NULL); - fseek(f, 0, SEEK_END); - src_size = ftell(f); - fseek(f, 0, SEEK_SET); - fut_opencl_src = malloc(src_size); - assert(fread(fut_opencl_src, 1, src_size, f) == src_size); - fclose(f); + fut_opencl_src = slurp_file(ctx->cfg.load_program_from, NULL); + assert(fut_opencl_src != NULL); } else { // Build the OpenCL program. First we have to concatenate all the fragments. for (const char **src = srcs; src && *src; src++) { @@ -680,28 +588,62 @@ fclose(f); } - prog = clCreateProgramWithSource(ctx->ctx, 1, src_ptr, &src_size, &error); - assert(error == 0); + if (ctx->cfg.load_binary_from == NULL) { + prog = clCreateProgramWithSource(ctx->ctx, 1, src_ptr, &src_size, &error); + assert(error == 0); - int compile_opts_size = 1024; - for (int i = 0; i < ctx->cfg.num_sizes; i++) { - compile_opts_size += strlen(ctx->cfg.size_names[i]) + 20; - } - char *compile_opts = malloc(compile_opts_size); + int compile_opts_size = 1024; + for (int i = 0; i < ctx->cfg.num_sizes; i++) { + compile_opts_size += strlen(ctx->cfg.size_names[i]) + 20; + } + char *compile_opts = malloc(compile_opts_size); - int w = snprintf(compile_opts, compile_opts_size, - "-DLOCKSTEP_WIDTH=%d ", - (int)ctx->lockstep_width); + int w = snprintf(compile_opts, compile_opts_size, + "-DLOCKSTEP_WIDTH=%d ", + (int)ctx->lockstep_width); - for (int i = 0; i < ctx->cfg.num_sizes; i++) { - w += snprintf(compile_opts+w, compile_opts_size-w, - "-D%s=%d ", ctx->cfg.size_names[i], - (int)ctx->cfg.size_values[i]); + for (int i = 0; i < ctx->cfg.num_sizes; i++) { + w += snprintf(compile_opts+w, compile_opts_size-w, + "-D%s=%d ", + ctx->cfg.size_vars[i], + (int)ctx->cfg.size_values[i]); + } + + OPENCL_SUCCEED_FATAL(build_opencl_program(prog, device_option.device, compile_opts)); + + free(compile_opts); + } else { + size_t binary_size; + unsigned char *fut_opencl_bin = + (unsigned char*) slurp_file(ctx->cfg.load_binary_from, &binary_size); + assert(fut_opencl_src != NULL); + const unsigned char *binaries[1] = { fut_opencl_bin }; + cl_int status = 0; + + prog = clCreateProgramWithBinary(ctx->ctx, 1, &device_option.device, + &binary_size, binaries, + &status, &error); + + OPENCL_SUCCEED_FATAL(status); + OPENCL_SUCCEED_FATAL(error); } - OPENCL_SUCCEED_FATAL(build_opencl_program(prog, device_option.device, compile_opts)); - free(compile_opts); free(fut_opencl_src); + + if (ctx->cfg.dump_binary_to != NULL) { + size_t binary_size; + OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARY_SIZES, + sizeof(size_t), &binary_size, NULL)); + unsigned char *binary = malloc(binary_size); + unsigned char *binaries[1] = { binary }; + OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARIES, + sizeof(unsigned char*), binaries, NULL)); + + FILE *f = fopen(ctx->cfg.dump_binary_to, "w"); + assert(f != NULL); + fwrite(binary, sizeof(char), binary_size, f); + fclose(f); + } return prog; } diff --git a/rts/csharp/opencl.cs b/rts/csharp/opencl.cs --- a/rts/csharp/opencl.cs +++ b/rts/csharp/opencl.cs @@ -38,6 +38,7 @@ public int NumSizes; public string[] SizeNames; + public string[] SizeVars; public int[] SizeValues; public string[] SizeClasses; } @@ -362,6 +363,7 @@ private void OpenCLConfigInit(out OpenCLConfig cfg, int num_sizes, string[] size_names, + string[] size_vars, int[] size_values, string[] size_classes) { @@ -379,6 +381,7 @@ cfg.NumSizes = num_sizes; cfg.SizeNames = size_names; + cfg.SizeVars = size_vars; cfg.SizeValues = size_values; cfg.SizeClasses = size_classes; } @@ -873,7 +876,7 @@ for (int i = 0; i < ctx.OpenCL.Cfg.NumSizes; i++) { compile_opts += String.Format("-D{0}={1} ", - ctx.OpenCL.Cfg.SizeNames[i], + ctx.OpenCL.Cfg.SizeVars[i], ctx.OpenCL.Cfg.SizeValues[i]); } @@ -897,11 +900,8 @@ int n = FutharkGetNumSizes(); for (int i = 0; i < n; i++) { - if (FutharkGetSizeEntry(i) == EntryPoint) - { - Console.WriteLine("{0} ({1})", FutharkGetSizeName(i), - FutharkGetSizeClass(i)); - } + Console.WriteLine("{0} ({1})", FutharkGetSizeName(i), + FutharkGetSizeClass(i)); } Environment.Exit(0); } diff --git a/rts/python/__init__.py b/rts/python/__init__.py deleted file mode 100644 --- a/rts/python/__init__.py +++ /dev/null diff --git a/rts/python/opencl.py b/rts/python/opencl.py --- a/rts/python/opencl.py +++ b/rts/python/opencl.py @@ -164,10 +164,13 @@ else: self.sizes[k] = v['value'] + # XXX: we perform only a subset of z-encoding here. Really, the + # compiler should provide us with the variables to which + # parameters are mapped. if (len(program_src) >= 0): return cl.Program(self.ctx, program_src).build( ["-DLOCKSTEP_WIDTH={}".format(lockstep_width)] - + ["-D{}={}".format(s,v) for (s,v) in self.sizes.items()]) + + ["-D{}={}".format(s.replace('z', 'zz').replace('.', 'zi'),v) for (s,v) in self.sizes.items()]) def opencl_alloc(self, min_size, tag): min_size = 1 if min_size == 0 else min_size 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 @@ -7,7 +7,6 @@ ) where -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S diff --git a/src/Futhark/Analysis/HORepresentation/MapNest.hs b/src/Futhark/Analysis/HORepresentation/MapNest.hs --- a/src/Futhark/Analysis/HORepresentation/MapNest.hs +++ b/src/Futhark/Analysis/HORepresentation/MapNest.hs @@ -16,7 +16,6 @@ import Control.Monad import Data.List import Data.Maybe -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S 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 @@ -72,7 +72,6 @@ import Data.Maybe import Data.Monoid ((<>)) import qualified Data.Sequence as Seq -import qualified Data.Semigroup as Sem import qualified Futhark.Representation.AST as Futhark import Futhark.Representation.SOACS.SOAC @@ -126,14 +125,13 @@ newtype ArrayTransforms = ArrayTransforms (Seq.Seq ArrayTransform) deriving (Eq, Ord, Show) -instance Sem.Semigroup ArrayTransforms where +instance Semigroup ArrayTransforms where ts1 <> ts2 = case viewf ts2 of t :< ts2' -> (ts1 |> t) <> ts2' EmptyF -> ts1 instance Monoid ArrayTransforms where mempty = noTransforms - mappend = (Sem.<>) instance Substitute ArrayTransforms where substituteNames substs (ArrayTransforms ts) = diff --git a/src/Futhark/Analysis/Metrics.hs b/src/Futhark/Analysis/Metrics.hs --- a/src/Futhark/Analysis/Metrics.hs +++ b/src/Futhark/Analysis/Metrics.hs @@ -22,7 +22,6 @@ import Data.String import Data.List import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import Futhark.Representation.AST @@ -48,12 +47,11 @@ newtype CountMetrics = CountMetrics [([Text], Text)] -instance Sem.Semigroup CountMetrics where +instance Semigroup CountMetrics where CountMetrics x <> CountMetrics y = CountMetrics $ x <> y instance Monoid CountMetrics where mempty = CountMetrics mempty - mappend = (Sem.<>) actualMetrics :: CountMetrics -> AstMetrics actualMetrics (CountMetrics metrics) = 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 @@ -8,6 +8,7 @@ , coerceIntPrimExp , true , false + , constFoldPrimExp , module Futhark.Representation.Primitive , (.&&.), (.||.), (.<.), (.<=.), (.>.), (.>=.), (.==.), (.&.), (.|.), (.^.) @@ -22,7 +23,9 @@ import Futhark.Util.IntegralExp import Futhark.Util.Pretty --- | A primitive expression parametrised over the representation of free variables. +-- | A primitive expression parametrised over the representation of +-- free variables. Note that the 'Functor', 'Traversable', and 'Num' +-- instances perform automatic (but simple) constant folding. data PrimExp v = LeafExp v PrimType | ValueExp PrimValue | BinOpExp BinOp (PrimExp v) (PrimExp v) @@ -66,7 +69,7 @@ traverse _ (ValueExp v) = pure $ ValueExp v traverse f (BinOpExp op x y) = - BinOpExp op <$> traverse f x <*> traverse f y + constFoldPrimExp <$> (BinOpExp op <$> traverse f x <*> traverse f y) traverse f (CmpOpExp op x y) = CmpOpExp op <$> traverse f x <*> traverse f y traverse f (ConvOpExp op x) = @@ -79,6 +82,29 @@ instance FreeIn v => FreeIn (PrimExp v) where freeIn = foldMap freeIn +-- | Perform quick and dirty constant folding on the top level of a +-- PrimExp. This is necessary because we want to consider +-- e.g. equality modulo constant folding. +constFoldPrimExp :: PrimExp v -> PrimExp v +constFoldPrimExp (BinOpExp Add{} x y) + | zeroIshExp x = y + | zeroIshExp y = x +constFoldPrimExp (BinOpExp Sub{} x y) + | zeroIshExp y = x +constFoldPrimExp (BinOpExp Mul{} x y) + | oneIshExp x = y + | oneIshExp y = x +constFoldPrimExp (BinOpExp SDiv{} x y) + | oneIshExp y = x +constFoldPrimExp (BinOpExp SQuot{} x y) + | oneIshExp y = x +constFoldPrimExp (BinOpExp UDiv{} x y) + | oneIshExp y = x +constFoldPrimExp (BinOpExp bop (ValueExp x) (ValueExp y)) + | Just z <- doBinOp bop x y = + ValueExp z +constFoldPrimExp e = e + -- The Num instance performs a little bit of magic: whenever an -- expression and a constant is combined with a binary operator, the -- type of the constant may be changed to be the type of the @@ -93,32 +119,13 @@ -- expressions to constants so that the above works. However, it is -- still a bit of a hack. instance Pretty v => Num (PrimExp v) where - x + y | zeroIshExp x = y - | zeroIshExp y = x - | IntType t <- primExpType x, - Just z <- constFold (doBinOp $ Add t) x y = z - | FloatType t <- primExpType x, - Just z <- constFold (doBinOp $ FAdd t) x y = z - | Just z <- msum [asIntOp Add x y, asFloatOp FAdd x y] = z + x + y | Just z <- msum [asIntOp Add x y, asFloatOp FAdd x y] = constFoldPrimExp z | otherwise = numBad "+" (x,y) - x - y | zeroIshExp y = x - | IntType t <- primExpType x, - Just z <- constFold (doBinOp $ Sub t) x y = z - | FloatType t <- primExpType x, - Just z <- constFold (doBinOp $ FSub t) x y = z - | Just z <- msum [asIntOp Sub x y, asFloatOp FSub x y] = z + x - y | Just z <- msum [asIntOp Sub x y, asFloatOp FSub x y] = constFoldPrimExp z | otherwise = numBad "-" (x,y) - x * y | zeroIshExp x = x - | zeroIshExp y = y - | oneIshExp x = y - | oneIshExp y = x - | IntType t <- primExpType x, - Just z <- constFold (doBinOp $ Mul t) x y = z - | FloatType t <- primExpType x, - Just z <- constFold (doBinOp $ FMul t) x y = z - | Just z <- msum [asIntOp Mul x y, asFloatOp FMul x y] = z + x * y | Just z <- msum [asIntOp Mul x y, asFloatOp FMul x y] = constFoldPrimExp z | otherwise = numBad "*" (x,y) abs x | IntType t <- primExpType x = UnOpExp (Abs t) x @@ -131,18 +138,17 @@ fromInteger = fromInt32 . fromInteger instance Pretty v => IntegralExp (PrimExp v) where - x `div` y | oneIshExp y = x - | Just z <- msum [asIntOp SDiv x y, asFloatOp FDiv x y] = z + x `div` y | Just z <- msum [asIntOp SDiv x y, asFloatOp FDiv x y] = constFoldPrimExp z | otherwise = numBad "div" (x,y) x `mod` y | Just z <- msum [asIntOp SMod x y] = z | otherwise = numBad "mod" (x,y) x `quot` y | oneIshExp y = x - | Just z <- msum [asIntOp SQuot x y] = z + | Just z <- msum [asIntOp SQuot x y] = constFoldPrimExp z | otherwise = numBad "quot" (x,y) - x `rem` y | Just z <- msum [asIntOp SRem x y] = z + x `rem` y | Just z <- msum [asIntOp SRem x y] = constFoldPrimExp z | otherwise = numBad "rem" (x,y) sgn (ValueExp (IntValue i)) = Just $ signum $ valueIntegral i @@ -220,13 +226,6 @@ asFloatExp _ _ = Nothing -constFold :: (PrimValue -> PrimValue -> Maybe PrimValue) - -> PrimExp v -> PrimExp v - -> Maybe (PrimExp v) -constFold f x y = do x' <- valueExp x - y' <- valueExp y - ValueExp <$> f x' y' - numBad :: Pretty a => String -> a -> b numBad s x = error $ "Invalid argument to PrimExp method " ++ s ++ ": " ++ pretty x @@ -279,11 +278,6 @@ oneIshExp :: PrimExp v -> Bool oneIshExp (ValueExp v) = oneIsh v oneIshExp _ = False - --- | Is the expression a constant value? -valueExp :: PrimExp v -> Maybe PrimValue -valueExp (ValueExp v) = Just v -valueExp _ = Nothing -- | If the given 'PrimExp' is a constant of the wrong integer type, -- coerce it to the given integer type. This is a workaround for an diff --git a/src/Futhark/Analysis/PrimExp/Convert.hs b/src/Futhark/Analysis/PrimExp/Convert.hs --- a/src/Futhark/Analysis/PrimExp/Convert.hs +++ b/src/Futhark/Analysis/PrimExp/Convert.hs @@ -92,7 +92,7 @@ replaceInPrimExp _ (ValueExp v) = ValueExp v replaceInPrimExp f (BinOpExp bop pe1 pe2) = - BinOpExp bop (replaceInPrimExp f pe1) (replaceInPrimExp f pe2) + constFoldPrimExp $ BinOpExp bop (replaceInPrimExp f pe1) (replaceInPrimExp f pe2) replaceInPrimExp f (CmpOpExp cop pe1 pe2) = CmpOpExp cop (replaceInPrimExp f pe1) (replaceInPrimExp f pe2) replaceInPrimExp f (UnOpExp uop pe) = diff --git a/src/Futhark/Analysis/Range.hs b/src/Futhark/Analysis/Range.hs --- a/src/Futhark/Analysis/Range.hs +++ b/src/Futhark/Analysis/Range.hs @@ -12,7 +12,6 @@ import qualified Data.Map.Strict as M import Control.Monad.Reader -import Data.Semigroup ((<>)) import Data.List import qualified Futhark.Analysis.ScalExp as SE diff --git a/src/Futhark/Analysis/SymbolTable.hs b/src/Futhark/Analysis/SymbolTable.hs --- a/src/Futhark/Analysis/SymbolTable.hs +++ b/src/Futhark/Analysis/SymbolTable.hs @@ -59,12 +59,10 @@ import Control.Monad.Reader import Data.Ord import Data.Maybe -import Data.Semigroup ((<>)) import Data.List hiding (elem, lookup) import qualified Data.List as L import qualified Data.Set as S import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import Prelude hiding (elem, lookup) @@ -88,7 +86,7 @@ -- loop? } -instance Sem.Semigroup (SymbolTable lore) where +instance Semigroup (SymbolTable lore) where table1 <> table2 = SymbolTable { loopDepth = max (loopDepth table1) (loopDepth table2) , bindings = bindings table1 <> bindings table2 @@ -98,7 +96,6 @@ instance Monoid (SymbolTable lore) where mempty = empty - mappend = (Sem.<>) empty :: SymbolTable lore empty = SymbolTable 0 M.empty mempty diff --git a/src/Futhark/Analysis/Usage.hs b/src/Futhark/Analysis/Usage.hs --- a/src/Futhark/Analysis/Usage.hs +++ b/src/Futhark/Analysis/Usage.hs @@ -8,7 +8,6 @@ ) where -import Data.Semigroup ((<>)) import Data.Foldable import qualified Data.Set as S diff --git a/src/Futhark/Analysis/UsageTable.hs b/src/Futhark/Analysis/UsageTable.hs --- a/src/Futhark/Analysis/UsageTable.hs +++ b/src/Futhark/Analysis/UsageTable.hs @@ -27,10 +27,8 @@ import Data.Bits import qualified Data.Foldable as Foldable import Data.List (foldl') -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified Data.Semigroup as Sem import Prelude hiding (lookup) @@ -40,13 +38,12 @@ newtype UsageTable = UsageTable (M.Map VName Usages) deriving (Eq, Show) -instance Sem.Semigroup UsageTable where +instance Semigroup UsageTable where UsageTable table1 <> UsageTable table2 = UsageTable $ M.unionWith (<>) table1 table2 instance Monoid UsageTable where mempty = empty - mappend = (Sem.<>) instance Substitute UsageTable where substituteNames subst (UsageTable table) @@ -115,12 +112,11 @@ newtype Usages = Usages Int deriving (Eq, Ord, Show) -instance Sem.Semigroup Usages where +instance Semigroup Usages where Usages x <> Usages y = Usages $ x .|. y instance Monoid Usages where mempty = Usages 0 - mappend = (Sem.<>) consumedU, inResultU, presentU :: Usages consumedU = Usages 1 diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Bench.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Simple tool for benchmarking Futhark programs. Use the @--json@ +-- flag for machine-readable output. +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.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.Test +import Futhark.Util (pmapIO) +import Futhark.Util.Options + +data BenchOptions = BenchOptions + { optBackend :: String + , optFuthark :: String + , optRunner :: String + , optRuns :: Int + , optExtraOptions :: [String] + , optJSON :: Maybe FilePath + , optTimeout :: Int + , optSkipCompilation :: Bool + , optExcludeCase :: [String] + , optIgnoreFiles :: [Regex] + , optEntryPoint :: Maybe String + } + +initialBenchOptions :: BenchOptions +initialBenchOptions = BenchOptions "c" "futhark" "" 10 [] Nothing (-1) False + ["nobench", "disable"] [] Nothing + +-- | 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. + -- Otherwise, CI tools and the like may believe we are hung and kill + -- us. + hSetBuffering stdout LineBuffering + benchmarks <- filter (not . ignored . fst) <$> testSpecsFromPaths paths + (skipped_benchmarks, compiled_benchmarks) <- + partitionEithers <$> pmapIO (compileBenchmark opts) benchmarks + + when (anyFailedToCompile skipped_benchmarks) exitFailure + + results <- concat <$> mapM (runBenchmark opts) compiled_benchmarks + case optJSON opts of + Nothing -> return () + Just file -> LBS.writeFile file $ encodeBenchResults results + when (anyFailed results) exitFailure + + where ignored f = any (`match` f) $ optIgnoreFiles opts + +anyFailed :: [BenchResult] -> Bool +anyFailed = any failedBenchResult + where failedBenchResult (BenchResult _ xs) = + any failedResult xs + failedResult (DataResult _ Left{}) = True + failedResult _ = False + +anyFailedToCompile :: [SkipReason] -> Bool +anyFailedToCompile = not . all (==Skipped) + +data SkipReason = Skipped | FailedToCompile | ReferenceFailed + deriving (Eq) + +compileBenchmark :: BenchOptions -> (FilePath, ProgramTest) + -> IO (Either SkipReason (FilePath, [InputOutputs])) +compileBenchmark opts (program, spec) = + case testAction spec of + RunCases cases _ _ | "nobench" `notElem` testTags spec, + "disable" `notElem` testTags spec, + any hasRuns cases -> + if optSkipCompilation opts + then do + exists <- doesFileExist $ binaryName program + if exists + then return $ Right (program, cases) + else do putStrLn $ binaryName program ++ " does not exist, but --skip-compilation passed." + return $ Left FailedToCompile + else do + putStr $ "Compiling " ++ program ++ "...\n" + + 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 + + Right () -> do + (futcode, _, futerr) <- liftIO $ readProcessWithExitCode futhark + [optBackend opts, program, "-o", binaryName program] "" + + 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 + futhark = optFuthark opts + +runBenchmark :: BenchOptions -> (FilePath, [InputOutputs]) -> IO [BenchResult] +runBenchmark opts (program, cases) = mapM forInputOutputs $ filter relevant cases + where forInputOutputs (InputOutputs entry_name runs) = do + putStr $ "Results for " ++ program' ++ ":\n" + BenchResult program' . catMaybes <$> + mapM (runBenchmarkCase opts program entry_name pad_to) runs + where program' = if entry_name == "main" + then program + else program ++ ":" ++ T.unpack entry_name + + relevant = maybe (const True) (==) (optEntryPoint opts) . T.unpack . iosEntryPoint + + pad_to = foldl max 0 $ concatMap (map (length . runDescription) . iosTestRuns) cases + +reportResult :: [RunResult] -> IO () +reportResult [] = + print (0::Int) +reportResult results = do + let runtimes = map (fromIntegral . runMicroseconds) results + avg = sum runtimes / fromIntegral (length runtimes) + rel_dev = stddevp runtimes / mean runtimes :: Double + 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 + +runBenchmarkCase :: BenchOptions -> FilePath -> T.Text -> Int -> TestRun + -> IO (Maybe DataResult) +runBenchmarkCase _ _ _ _ (TestRun _ _ RunTimeFailure{} _ _) = + return Nothing -- Not our concern, we are not a testing tool. +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"] + + -- 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 () + +commandLineOptions :: [FunOptDescr BenchOptions] +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 }) + "PROGRAM") + "The compiler used (defaults to 'futhark-c')." + , Option [] ["futhark"] + (ReqArg (\prog -> Right $ \config -> config { optFuthark = prog }) + "PROGRAM") + "The binary used for operations (defaults to 'futhark')." + , Option [] ["runner"] + (ReqArg (\prog -> Right $ \config -> config { optRunner = prog }) "PROGRAM") + "The program used to run the Futhark-generated programs (defaults to nothing)." + , Option "p" ["pass-option"] + (ReqArg (\opt -> + Right $ \config -> + config { optExtraOptions = opt : optExtraOptions config }) + "OPT") + "Pass this option to programs being run." + , Option [] ["json"] + (ReqArg (\file -> + Right $ \config -> config { optJSON = Just file}) + "FILE") + "Scatter results in JSON format here." + , Option [] ["timeout"] + (ReqArg (\n -> + case reads n of + [(n', "")] + | n' < max_timeout -> + Right $ \config -> config { optTimeout = fromIntegral n' } + _ -> + Left $ error $ "'" ++ n ++ + "' is not an integer smaller than" ++ show max_timeout ++ ".") + "SECONDS") + "Number of seconds before a dataset is aborted." + , Option [] ["skip-compilation"] + (NoArg $ Right $ \config -> config { optSkipCompilation = True }) + "Use already compiled program." + , Option [] ["exclude-case"] + (ReqArg (\s -> Right $ \config -> + config { optExcludeCase = s : optExcludeCase config }) + "TAG") + "Do not run test cases with this tag." + , Option [] ["ignore-files"] + (ReqArg (\s -> Right $ \config -> + config { optIgnoreFiles = makeRegex s : optIgnoreFiles config }) + "REGEX") + "Ignore files matching this regular expression." + , Option "e" ["entry-point"] + (ReqArg (\s -> Right $ \config -> + config { optEntryPoint = Just s }) + "NAME") + "Only run this entry point." + ] + where max_timeout :: Int + max_timeout = maxBound `div` 1000000 + +main :: String -> [String] -> IO () +main = mainWithOptions initialBenchOptions commandLineOptions "options... programs..." $ \progs config -> + Just $ runBenchmarks config progs + +--- The following extracted from hstats package by Marshall Beddoe: +--- https://hackage.haskell.org/package/hstats-0.3 + +-- | Numerically stable mean +mean :: Floating a => [a] -> a +mean x = fst $ foldl' (\(!m, !n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x + +-- | Standard deviation of population +stddevp :: (Floating a) => [a] -> a +stddevp xs = sqrt $ pvar xs + +-- | Population variance +pvar :: (Floating a) => [a] -> a +pvar xs = centralMoment xs (2::Int) + +-- | Central moments +centralMoment :: (Floating b, Integral t) => [b] -> t -> b +centralMoment _ 1 = 0 +centralMoment xs r = sum (map (\x -> (x-m)^r) xs) / n + where + m = mean xs + n = fromIntegral $ length xs diff --git a/src/Futhark/CLI/C.hs b/src/Futhark/CLI/C.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/C.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} +module Futhark.CLI.C (main) where + +import Control.Monad.IO.Class +import System.FilePath +import System.Exit + +import Futhark.Pipeline +import Futhark.Passes +import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC +import Futhark.Util.Pretty (prettyText) +import Futhark.Compiler.CLI +import Futhark.Util + +main :: String -> [String] -> IO () +main = compilerMain () [] + "Compile sequential C" "Generate sequential C code from optimised Futhark program." + sequentialCpuPipeline $ \() mode outpath prog -> do + cprog <- either (`internalError` prettyText prog) return =<< + SequentialC.compileProg prog + let cpath = outpath `addExtension` "c" + hpath = outpath `addExtension` "h" + + case mode of + ToLibrary -> do + let (header, impl) = SequentialC.asLibrary cprog + liftIO $ writeFile hpath header + liftIO $ writeFile cpath impl + ToExecutable -> do + liftIO $ writeFile cpath $ SequentialC.asExecutable cprog + ret <- liftIO $ runProgramWithExitCode "gcc" + [cpath, "-O3", "-std=c99", "-lm", "-o", outpath] "" + case ret of + Left err -> + externalErrorS $ "Failed to run gcc: " ++ show err + Right (ExitFailure code, _, gccerr) -> + externalErrorS $ "gcc failed with code " ++ + show code ++ ":\n" ++ gccerr + Right (ExitSuccess, _, _) -> + return () diff --git a/src/Futhark/CLI/CSOpenCL.hs b/src/Futhark/CLI/CSOpenCL.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/CSOpenCL.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +module Futhark.CLI.CSOpenCL (main) where + +import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) +import System.Directory +import System.Environment +import System.Exit +import System.FilePath + +import Futhark.Pipeline +import Futhark.Passes +import qualified Futhark.CodeGen.Backends.CSOpenCL as CSOpenCL +import Futhark.Util.Pretty (prettyText) +import Futhark.Compiler.CLI +import Futhark.Util + +main :: String -> [String] -> IO () +main = compilerMain () [] + "Compile OpenCL C#" "Generate OpenCL C# code from optimised Futhark program." + gpuPipeline $ \() mode outpath prog -> do + mono_libs <- liftIO $ fromMaybe "." <$> lookupEnv "MONO_PATH" + + let class_name = + case mode of ToLibrary -> Just $ takeBaseName outpath + ToExecutable -> Nothing + csprog <- either (`internalError` prettyText prog) return =<< + CSOpenCL.compileProg class_name prog + + let cspath = outpath `addExtension` "cs" + liftIO $ writeFile cspath csprog + + case mode of + ToLibrary -> return () + ToExecutable -> do + ret <- liftIO $ runProgramWithExitCode "csc" + ["-out:" ++ outpath, "-lib:"++mono_libs, "-r:Cloo.clSharp.dll,Mono.Options.dll", cspath, "/unsafe"] "" + case ret of + Left err -> + externalErrorS $ "Failed to run csc: " ++ show err + Right (ExitFailure code, cscwarn, cscerr) -> + externalErrorS $ "csc failed with code " ++ show code ++ ":\n" ++ cscerr ++ cscwarn + Right (ExitSuccess, _, _) -> liftIO $ do + perms <- liftIO $ getPermissions outpath + setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/Futhark/CLI/CSharp.hs b/src/Futhark/CLI/CSharp.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/CSharp.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +module Futhark.CLI.CSharp (main) where + +import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) +import System.FilePath +import System.Directory +import System.Exit +import System.Environment + +import Futhark.Pipeline +import Futhark.Passes +import qualified Futhark.CodeGen.Backends.SequentialCSharp as SequentialCS +import Futhark.Util.Pretty (prettyText) +import Futhark.Compiler.CLI +import Futhark.Util + +main :: String -> [String] -> IO () +main = compilerMain () [] + "Compile sequential C#" "Generate sequential C# code from optimised Futhark program." + sequentialCpuPipeline $ \() mode outpath prog -> do + mono_libs <- liftIO $ fromMaybe "." <$> lookupEnv "MONO_PATH" + let class_name = + case mode of ToLibrary -> Just $ takeBaseName outpath + ToExecutable -> Nothing + csprog <- either (`internalError` prettyText prog) return =<< + SequentialCS.compileProg class_name prog + + let cspath = outpath `addExtension` "cs" + liftIO $ writeFile cspath csprog + + case mode of + ToLibrary -> return () + ToExecutable -> do + ret <- liftIO $ runProgramWithExitCode "csc" + ["-out:" ++ outpath + , "-lib:"++mono_libs + , "-r:Cloo.clSharp.dll" + , "-r:Mono.Options.dll" + , cspath + , "/unsafe"] "" + case ret of + Left err -> + externalErrorS $ "Failed to run csc: " ++ show err + Right (ExitFailure code, cscwarn, cscerr) -> + externalErrorS $ "csc failed with code " ++ show code ++ ":\n" ++ cscerr ++ cscwarn + Right (ExitSuccess, _, _) -> liftIO $ do + perms <- liftIO $ getPermissions outpath + setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/Futhark/CLI/CUDA.hs b/src/Futhark/CLI/CUDA.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/CUDA.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +module Futhark.CLI.CUDA (main) where + +import Control.Monad.IO.Class +import System.FilePath +import System.Exit + +import Futhark.Pipeline +import Futhark.Passes +import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA +import Futhark.Util +import Futhark.Util.Pretty (prettyText) +import Futhark.Compiler.CLI + +main :: String -> [String] -> IO () +main = compilerMain () [] + "Compile CUDA" "Generate CUDA/C code from optimised Futhark program." + gpuPipeline $ \() mode outpath prog -> do + cprog <- either (`internalError` prettyText prog) return =<< + CCUDA.compileProg prog + let cpath = outpath `addExtension` "c" + hpath = outpath `addExtension` "h" + extra_options = [ "-lcuda" + , "-lnvrtc" + ] + case mode of + ToLibrary -> do + let (header, impl) = CCUDA.asLibrary cprog + liftIO $ writeFile hpath header + liftIO $ writeFile cpath impl + ToExecutable -> do + liftIO $ writeFile cpath $ CCUDA.asExecutable cprog + let args = [cpath, "-O3", "-std=c99", "-lm", "-o", outpath] + ++ extra_options + ret <- liftIO $ runProgramWithExitCode "gcc" args "" + case ret of + Left err -> + externalErrorS $ "Failed to run gcc: " ++ show err + Right (ExitFailure code, _, gccerr) -> + externalErrorS $ "gcc failed with code " ++ + show code ++ ":\n" ++ gccerr + Right (ExitSuccess, _, _) -> + return () diff --git a/src/Futhark/CLI/Datacmp.hs b/src/Futhark/CLI/Datacmp.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Datacmp.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +module Futhark.CLI.Datacmp (main) where + +import qualified Data.ByteString.Lazy.Char8 as BS +import System.Exit +import System.IO + +import Futhark.Test.Values +import Futhark.Util.Options + +main :: String -> [String] -> IO () +main = mainWithOptions () [] " " f + where f [file_a, file_b] () = Just $ do + vs_a_maybe <- readValues <$> BS.readFile file_a + vs_b_maybe <- readValues <$> BS.readFile file_b + case (vs_a_maybe, vs_b_maybe) of + (Nothing, _) -> + error $ "Error reading values from " ++ file_a + (_, Nothing) -> + error $ "Error reading values from " ++ file_b + (Just vs_a, Just vs_b) -> + case compareValues vs_a vs_b of + [] -> return () + es -> do + mapM_ (hPrint stderr) es + exitWith $ ExitFailure 2 + + f _ _ = + Nothing diff --git a/src/Futhark/CLI/Dataset.hs b/src/Futhark/CLI/Dataset.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Dataset.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Randomly generate Futhark input files containing values of a +-- specified type and shape. +module Futhark.CLI.Dataset (main) where + +import Control.Monad +import Control.Monad.ST +import qualified Data.Binary as Bin +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Word +import qualified Data.Vector.Unboxed.Mutable as UMVec +import qualified Data.Vector.Unboxed as UVec +import Data.Vector.Generic (freeze) + +import System.Console.GetOpt +import System.Random + +import Language.Futhark.Syntax hiding (Value, PrimValue(..), IntValue(..), FloatValue(..)) +import Language.Futhark.Attributes (UncheckedTypeExp, namesToPrimTypes) +import Language.Futhark.Parser +import Language.Futhark.Pretty () + +import Futhark.Test.Values +import Futhark.Util.Options + +main :: String -> [String] -> IO () +main = mainWithOptions initialDataOptions commandLineOptions "options..." f + where f [] config + | null $ optOrders config = Just $ do + maybe_vs <- readValues <$> BS.getContents + case maybe_vs of + Nothing -> error "Malformed data on standard input." + Just vs -> + case format config of + Text -> mapM_ (putStrLn . pretty) vs + Binary -> mapM_ (BS.putStr . Bin.encode) vs + Type -> mapM_ (putStrLn . pretty . valueType) vs + | otherwise = + Just $ zipWithM_ ($) (optOrders config) $ map mkStdGen [optSeed config..] + f _ _ = + Nothing + +data OutputFormat = Text + | Binary + | Type + deriving (Eq, Ord, Show) + +data DataOptions = DataOptions + { optSeed :: Int + , optRange :: RandomConfiguration + , optOrders :: [StdGen -> IO ()] + , format :: OutputFormat + } + +initialDataOptions :: DataOptions +initialDataOptions = DataOptions 0 initialRandomConfiguration [] Text + +commandLineOptions :: [FunOptDescr DataOptions] +commandLineOptions = [ + Option "s" ["seed"] + (ReqArg (\n -> + case reads n of + [(n', "")] -> + Right $ \config -> config { optSeed = n' } + _ -> + Left $ error $ "'" ++ n ++ "' is not an integer.") + "SEED") + "The seed to use when initialising the RNG." + , Option "g" ["generate"] + (ReqArg (\t -> + case tryMakeGenerator t of + Right g -> + Right $ \config -> + config { optOrders = + optOrders config ++ + [g (optRange config) (format config)] + } + Left err -> + Left $ error err) + "TYPE") + "Generate a random value of this type." + , Option [] ["text"] + (NoArg $ Right $ \opts -> opts { format = Text }) + "Output data in text format (must precede --generate)." + , Option "b" ["binary"] + (NoArg $ Right $ \opts -> opts { format = Binary }) + "Output data in binary Futhark format (must precede --generate)." + , Option "t" ["type"] + (NoArg $ Right $ \opts -> opts { format = Type }) + "Output the type (textually) rather than the value (must precede --generate)." + , setRangeOption "i8" seti8Range + , setRangeOption "i16" seti16Range + , setRangeOption "i32" seti32Range + , setRangeOption "i64" seti64Range + , setRangeOption "u8" setu8Range + , setRangeOption "u16" setu16Range + , setRangeOption "u32" setu32Range + , setRangeOption "u64" setu64Range + , setRangeOption "f32" setf32Range + , setRangeOption "f64" setf64Range + ] + +setRangeOption :: Read a => String + -> (Range a -> RandomConfiguration -> RandomConfiguration) + -> FunOptDescr DataOptions +setRangeOption tname set = + Option "" [name] + (ReqArg (\b -> + let (lower,rest) = span (/=':') b + upper = drop 1 rest + in case (reads lower, reads upper) of + ([(lower', "")], [(upper', "")]) -> + Right $ \config -> + config { optRange = set (lower', upper') $ optRange config } + _ -> + Left $ error $ "Invalid bounds: " ++ b + ) + "MIN:MAX") $ + "Range of " ++ tname ++ " values." + where name = tname ++ "-bounds" + +tryMakeGenerator :: String -> Either String (RandomConfiguration -> OutputFormat -> StdGen -> IO ()) +tryMakeGenerator t + | Just vs <- readValues $ BS.pack t = + return $ \_ fmt _ -> mapM_ (putValue fmt) vs + | otherwise = do + t' <- toValueType =<< either (Left . show) Right (parseType name (T.pack t)) + return $ \conf fmt stdgen -> do + let (v, _) = randomValue conf t' stdgen + putValue fmt v + where name = "option " ++ t + putValue Text = putStrLn . pretty + putValue Binary = BS.putStr . Bin.encode + putValue Type = putStrLn . pretty . valueType + +toValueType :: UncheckedTypeExp -> Either String ValueType +toValueType TETuple{} = Left "Cannot handle tuples yet." +toValueType TERecord{} = Left "Cannot handle records yet." +toValueType TEApply{} = Left "Cannot handle type applications yet." +toValueType TEArrow{} = Left "Cannot generate functions." +toValueType TEEnum{} = Left "Cannot handle enums yet." +toValueType (TEUnique t _) = toValueType t +toValueType (TEArray t d _) = do + d' <- constantDim d + ValueType ds t' <- toValueType t + return $ ValueType (d':ds) t' + where constantDim (ConstDim k) = Right k + constantDim _ = Left "Array has non-constant dimension declaration." +toValueType (TEVar (QualName [] v) _) + | Just t <- M.lookup v namesToPrimTypes = Right $ ValueType [] t +toValueType (TEVar v _) = + Left $ "Unknown type " ++ pretty v + +-- | Closed interval, as in @System.Random@. +type Range a = (a, a) + +data RandomConfiguration = RandomConfiguration + { i8Range :: Range Int8 + , i16Range :: Range Int16 + , i32Range :: Range Int32 + , i64Range :: Range Int64 + , u8Range :: Range Word8 + , u16Range :: Range Word16 + , u32Range :: Range Word32 + , u64Range :: Range Word64 + , f32Range :: Range Float + , f64Range :: Range Double + } + +-- The following lines provide evidence about how Haskells record +-- system sucks. +seti8Range :: Range Int8 -> RandomConfiguration -> RandomConfiguration +seti8Range bounds config = config { i8Range = bounds } +seti16Range :: Range Int16 -> RandomConfiguration -> RandomConfiguration +seti16Range bounds config = config { i16Range = bounds } +seti32Range :: Range Int32 -> RandomConfiguration -> RandomConfiguration +seti32Range bounds config = config { i32Range = bounds } +seti64Range :: Range Int64 -> RandomConfiguration -> RandomConfiguration +seti64Range bounds config = config { i64Range = bounds } + +setu8Range :: Range Word8 -> RandomConfiguration -> RandomConfiguration +setu8Range bounds config = config { u8Range = bounds } +setu16Range :: Range Word16 -> RandomConfiguration -> RandomConfiguration +setu16Range bounds config = config { u16Range = bounds } +setu32Range :: Range Word32 -> RandomConfiguration -> RandomConfiguration +setu32Range bounds config = config { u32Range = bounds } +setu64Range :: Range Word64 -> RandomConfiguration -> RandomConfiguration +setu64Range bounds config = config { u64Range = bounds } + +setf32Range :: Range Float -> RandomConfiguration -> RandomConfiguration +setf32Range bounds config = config { f32Range = bounds } +setf64Range :: Range Double -> RandomConfiguration -> RandomConfiguration +setf64Range bounds config = config { f64Range = bounds } + +initialRandomConfiguration :: RandomConfiguration +initialRandomConfiguration = RandomConfiguration + (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) + (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) + (0.0, 1.0) (0.0, 1.0) + +randomValue :: RandomConfiguration -> ValueType -> StdGen -> (Value, StdGen) +randomValue conf (ValueType ds t) stdgen = + case t of + Signed Int8 -> gen i8Range Int8Value + Signed Int16 -> gen i16Range Int16Value + Signed Int32 -> gen i32Range Int32Value + Signed Int64 -> gen i64Range Int64Value + Unsigned Int8 -> gen u8Range Word8Value + Unsigned Int16 -> gen u16Range Word16Value + Unsigned Int32 -> gen u32Range Word32Value + Unsigned Int64 -> gen u64Range Word64Value + FloatType Float32 -> gen f32Range Float32Value + FloatType Float64 -> gen f64Range Float64Value + Bool -> gen (const (False,True)) BoolValue + where gen range final = randomVector (range conf) final ds stdgen + +randomVector :: (UMVec.Unbox v, Random v) => + Range v + -> (UVec.Vector Int -> UVec.Vector v -> Value) + -> [Int] -> StdGen + -> (Value, StdGen) +randomVector range final ds stdgen = runST $ do + -- USe some nice impure computation where we can preallocate a + -- vector of the desired size, populate it via the random number + -- generator, and then finally reutrn a frozen binary vector. + arr <- UMVec.new n + let fill stdgen' i + | i < n = do + let (v, stdgen'') = randomR range stdgen' + UMVec.write arr i v + fill stdgen'' $! i+1 + | otherwise = do + arr' <- final (UVec.fromList ds) <$> freeze arr + return (arr', stdgen') + fill stdgen 0 + where n = product ds diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Dev.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE RankNTypes #-} +-- | Futhark Compiler Driver +module Futhark.CLI.Dev (main) where + +import Data.Maybe +import Control.Category (id) +import Control.Monad +import Control.Monad.State +import qualified Data.Text.IO as T +import System.IO +import System.Exit +import System.Console.GetOpt + +import Prelude hiding (id) + +import Futhark.Pass +import Futhark.Actions +import Futhark.Compiler +import Language.Futhark.Parser (parseFuthark) +import Futhark.Util.Options +import Futhark.Pipeline +import qualified Futhark.Representation.SOACS as SOACS +import Futhark.Representation.SOACS (SOACS) +import qualified Futhark.Representation.Kernels as Kernels +import Futhark.Representation.Kernels (Kernels) +import qualified Futhark.Representation.ExplicitMemory as ExplicitMemory +import Futhark.Representation.ExplicitMemory (ExplicitMemory) +import Futhark.Representation.AST (Prog, pretty) +import Futhark.TypeCheck (Checkable) +import qualified Futhark.Util.Pretty as PP + +import Futhark.Internalise.Defunctorise as Defunctorise +import Futhark.Internalise.Monomorphise as Monomorphise +import Futhark.Internalise.Defunctionalise as Defunctionalise +import Futhark.Optimise.InliningDeadFun +import Futhark.Optimise.CSE +import Futhark.Optimise.Fusion +import Futhark.Pass.FirstOrderTransform +import Futhark.Pass.Simplify +import Futhark.Optimise.InPlaceLowering +import Futhark.Optimise.DoubleBuffer +import Futhark.Optimise.TileLoops +import Futhark.Optimise.Unstream +import Futhark.Pass.KernelBabysitting +import Futhark.Pass.ExtractKernels +import Futhark.Pass.ExpandAllocations +import Futhark.Pass.ExplicitAllocations +import Futhark.Passes + +-- | What to do with the program after it has been read. +data FutharkPipeline = PrettyPrint + -- ^ Just print it. + | TypeCheck + -- ^ Run the type checker; print type errors. + | Pipeline [UntypedPass] + -- ^ Run this pipeline. + | Defunctorise + -- ^ Partially evaluate away the module language. + | Monomorphise + -- ^ Defunctorise and monomorphise. + | Defunctionalise + -- ^ Defunctorise, monomorphise, and defunctionalise. + +data Config = Config { futharkConfig :: FutharkConfig + , futharkPipeline :: FutharkPipeline + -- ^ Nothing is distinct from a empty pipeline - + -- it means we don't even run the internaliser. + , futharkAction :: UntypedAction + } + + +-- | Get a Futhark pipeline from the configuration - an empty one if +-- none exists. +getFutharkPipeline :: Config -> [UntypedPass] +getFutharkPipeline = toPipeline . futharkPipeline + where toPipeline (Pipeline p) = p + toPipeline _ = [] + +data UntypedPassState = SOACS (Prog SOACS.SOACS) + | Kernels (Prog Kernels.Kernels) + | ExplicitMemory (Prog ExplicitMemory.ExplicitMemory) + +getSOACSProg :: UntypedPassState -> Maybe (Prog SOACS.SOACS) +getSOACSProg (SOACS prog) = Just prog +getSOACSProg _ = Nothing + +class Representation s where + -- | A human-readable description of the representation expected or + -- contained, usable for error messages. + representation :: s -> String + +instance Representation UntypedPassState where + representation (SOACS _) = "SOACS" + representation (Kernels _) = "Kernels" + representation (ExplicitMemory _) = "ExplicitMemory" + +instance PP.Pretty UntypedPassState where + ppr (SOACS prog) = PP.ppr prog + ppr (Kernels prog) = PP.ppr prog + ppr (ExplicitMemory prog) = PP.ppr prog + +newtype UntypedPass = UntypedPass (UntypedPassState + -> PipelineConfig + -> FutharkM UntypedPassState) + +data UntypedAction = SOACSAction (Action SOACS) + | KernelsAction (Action Kernels) + | ExplicitMemoryAction (Action ExplicitMemory) + | PolyAction (Action SOACS) (Action Kernels) (Action ExplicitMemory) + +untypedActionName :: UntypedAction -> String +untypedActionName (SOACSAction a) = actionName a +untypedActionName (KernelsAction a) = actionName a +untypedActionName (ExplicitMemoryAction a) = actionName a +untypedActionName (PolyAction a _ _) = actionName a + +instance Representation UntypedAction where + representation (SOACSAction _) = "SOACS" + representation (KernelsAction _) = "Kernels" + representation (ExplicitMemoryAction _) = "ExplicitMemory" + representation PolyAction{} = "" + +newConfig :: Config +newConfig = Config newFutharkConfig (Pipeline []) $ PolyAction printAction printAction printAction + +changeFutharkConfig :: (FutharkConfig -> FutharkConfig) + -> Config -> Config +changeFutharkConfig f cfg = cfg { futharkConfig = f $ futharkConfig cfg } + +type FutharkOption = FunOptDescr Config + +passOption :: String -> UntypedPass -> String -> [String] -> FutharkOption +passOption desc pass short long = + Option short long + (NoArg $ Right $ \cfg -> + cfg { futharkPipeline = Pipeline $ getFutharkPipeline cfg ++ [pass] }) + desc + +explicitMemoryProg :: String -> UntypedPassState -> FutharkM (Prog ExplicitMemory.ExplicitMemory) +explicitMemoryProg _ (ExplicitMemory prog) = + return prog +explicitMemoryProg name rep = + externalErrorS $ "Pass " ++ name ++ + " expects ExplicitMemory representation, but got " ++ representation rep + +soacsProg :: String -> UntypedPassState -> FutharkM (Prog SOACS.SOACS) +soacsProg _ (SOACS prog) = + return prog +soacsProg name rep = + externalErrorS $ "Pass " ++ name ++ + " expects SOACS representation, but got " ++ representation rep + +kernelsProg :: String -> UntypedPassState -> FutharkM (Prog Kernels.Kernels) +kernelsProg _ (Kernels prog) = + return prog +kernelsProg name rep = + externalErrorS $ + "Pass " ++ name ++" expects Kernels representation, but got " ++ representation rep + +typedPassOption :: (Checkable fromlore, Checkable tolore) => + (String -> UntypedPassState -> FutharkM (Prog fromlore)) + -> (Prog tolore -> UntypedPassState) + -> Pass fromlore tolore + -> String + -> FutharkOption +typedPassOption getProg putProg pass short = + passOption (passDescription pass) (UntypedPass perform) short long + where perform s config = do + prog <- getProg (passName pass) s + putProg <$> runPasses (onePass pass) config prog + + long = [passLongOption pass] + +soacsPassOption :: Pass SOACS SOACS -> String -> FutharkOption +soacsPassOption = + typedPassOption soacsProg SOACS + +kernelsPassOption :: Pass Kernels Kernels -> String -> FutharkOption +kernelsPassOption = + typedPassOption kernelsProg Kernels + +explicitMemoryPassOption :: Pass ExplicitMemory ExplicitMemory -> String -> FutharkOption +explicitMemoryPassOption = + typedPassOption explicitMemoryProg ExplicitMemory + +simplifyOption :: String -> FutharkOption +simplifyOption short = + passOption (passDescription pass) (UntypedPass perform) short long + where perform (SOACS prog) config = + SOACS <$> runPasses (onePass simplifySOACS) config prog + perform (Kernels prog) config = + Kernels <$> runPasses (onePass simplifyKernels) config prog + perform (ExplicitMemory prog) config = + ExplicitMemory <$> runPasses (onePass simplifyExplicitMemory) config prog + + long = [passLongOption pass] + pass = simplifySOACS + +cseOption :: String -> FutharkOption +cseOption short = + passOption (passDescription pass) (UntypedPass perform) short long + where perform (SOACS prog) config = + SOACS <$> runPasses (onePass $ performCSE True) config prog + perform (Kernels prog) config = + Kernels <$> runPasses (onePass $ performCSE True) config prog + perform (ExplicitMemory prog) config = + ExplicitMemory <$> runPasses (onePass $ performCSE False) config prog + + long = [passLongOption pass] + pass = performCSE True :: Pass SOACS SOACS + +pipelineOption :: (UntypedPassState -> Maybe (Prog fromlore)) + -> String + -> (Prog tolore -> UntypedPassState) + -> String + -> Pipeline fromlore tolore + -> String + -> [String] + -> FutharkOption +pipelineOption getprog repdesc repf desc pipeline = + passOption desc $ UntypedPass pipelinePass + where pipelinePass rep config = + case getprog rep of + Just prog -> + repf <$> runPasses pipeline config prog + Nothing -> + externalErrorS $ "Expected " ++ repdesc ++ " representation, but got " ++ + representation rep + +soacsPipelineOption :: String -> Pipeline SOACS SOACS -> String -> [String] + -> FutharkOption +soacsPipelineOption = pipelineOption getSOACSProg "SOACS" SOACS + +kernelsPipelineOption :: String -> Pipeline SOACS Kernels -> String -> [String] + -> FutharkOption +kernelsPipelineOption = pipelineOption getSOACSProg "Kernels" Kernels + +explicitMemoryPipelineOption :: String -> Pipeline SOACS ExplicitMemory -> String -> [String] + -> FutharkOption +explicitMemoryPipelineOption = pipelineOption getSOACSProg "ExplicitMemory" ExplicitMemory + +commandLineOptions :: [FutharkOption] +commandLineOptions = + [ Option "v" ["verbose"] + (OptArg (Right . changeFutharkConfig . incVerbosity) "FILE") + "Print verbose output on standard error; wrong program to FILE." + , Option [] ["Werror"] + (NoArg $ Right $ changeFutharkConfig $ \opts -> opts { futharkWerror = True }) + "Treat warnings as errors." + + , Option "t" ["type-check"] + (NoArg $ Right $ \opts -> + opts { futharkPipeline = TypeCheck }) + "Type-check the program and print errors on standard error." + + , Option [] ["pretty-print"] + (NoArg $ Right $ \opts -> + opts { futharkPipeline = PrettyPrint }) + "Parse and pretty-print the AST of the given program." + + , Option [] ["compile-imperative"] + (NoArg $ Right $ \opts -> + opts { futharkAction = ExplicitMemoryAction impCodeGenAction }) + "Translate program into the imperative IL and write it on standard output." + , Option [] ["compile-imperative-kernels"] + (NoArg $ Right $ \opts -> + opts { futharkAction = ExplicitMemoryAction kernelImpCodeGenAction }) + "Translate program into the imperative IL with kernels and write it on standard output." + , Option [] ["range-analysis"] + (NoArg $ Right $ \opts -> opts { futharkAction = PolyAction rangeAction rangeAction rangeAction }) + "Print the program with range annotations added." + , Option "p" ["print"] + (NoArg $ Right $ \opts -> opts { futharkAction = PolyAction printAction printAction printAction }) + "Prettyprint the resulting internal representation on standard output (default action)." + , Option "m" ["metrics"] + (NoArg $ Right $ \opts -> opts { futharkAction = PolyAction metricsAction metricsAction metricsAction }) + "Print AST metrics of the resulting internal representation on standard output." + , Option [] ["defunctorise"] + (NoArg $ Right $ \opts -> opts { futharkPipeline = Defunctorise }) + "Partially evaluate all module constructs and print the residual program." + , Option [] ["monomorphise"] + (NoArg $ Right $ \opts -> opts { futharkPipeline = Monomorphise }) + "Monomorphise the program." + , Option [] ["defunctionalise"] + (NoArg $ Right $ \opts -> opts { futharkPipeline = Defunctionalise }) + "Defunctionalise the program." + , typedPassOption soacsProg Kernels firstOrderTransform "f" + , soacsPassOption fuseSOACs "o" + , soacsPassOption inlineAndRemoveDeadFunctions [] + , kernelsPassOption inPlaceLowering [] + , kernelsPassOption babysitKernels [] + , kernelsPassOption tileLoops [] + , kernelsPassOption unstream [] + , typedPassOption soacsProg Kernels extractKernels [] + + , typedPassOption kernelsProg ExplicitMemory explicitAllocations "a" + + , explicitMemoryPassOption doubleBuffer [] + , explicitMemoryPassOption expandAllocations [] + + , cseOption [] + , simplifyOption "e" + + , soacsPipelineOption "Run the default optimised pipeline" + standardPipeline "s" ["standard"] + , kernelsPipelineOption "Run the default optimised kernels pipeline" + kernelsPipeline [] ["kernels"] + , explicitMemoryPipelineOption "Run the full GPU compilation pipeline" + gpuPipeline [] ["gpu"] + , explicitMemoryPipelineOption "Run the sequential CPU compilation pipeline" + sequentialCpuPipeline [] ["cpu"] + ] + +incVerbosity :: Maybe FilePath -> FutharkConfig -> FutharkConfig +incVerbosity file cfg = + cfg { futharkVerbose = (v, file `mplus` snd (futharkVerbose cfg)) } + where v = case fst $ futharkVerbose cfg of + NotVerbose -> Verbose + Verbose -> VeryVerbose + VeryVerbose -> VeryVerbose + +-- | Entry point. Non-interactive, except when reading interpreter +-- input from standard input. +main :: String -> [String] -> IO () +main = mainWithOptions newConfig commandLineOptions "options... program" compile + where compile [file] config = + Just $ do + res <- runFutharkM (m file config) $ + fst $ futharkVerbose $ futharkConfig config + case res of + Left err -> do + dumpError (futharkConfig config) err + exitWith $ ExitFailure 2 + Right () -> return () + compile _ _ = + Nothing + m file config = + case futharkPipeline config of + TypeCheck -> do + -- No pipeline; just read the program and type check + (warnings, _, _) <- readProgram file + liftIO $ hPutStr stderr $ show warnings + PrettyPrint -> liftIO $ do + maybe_prog <- parseFuthark file <$> T.readFile file + case maybe_prog of + Left err -> fail $ show err + Right prog -> putStrLn $ pretty prog + Defunctorise -> do + (_, imports, src) <- readProgram file + liftIO $ mapM_ (putStrLn . pretty) $ + evalState (Defunctorise.transformProg imports) src + Monomorphise -> do + (_, imports, src) <- readProgram file + liftIO $ mapM_ (putStrLn . pretty) $ flip evalState src $ + Defunctorise.transformProg imports + >>= Monomorphise.transformProg + Defunctionalise -> do + (_, imports, src) <- readProgram file + liftIO $ mapM_ (putStrLn . pretty) $ flip evalState src $ + Defunctorise.transformProg imports + >>= Monomorphise.transformProg + >>= Defunctionalise.transformProg + Pipeline{} -> do + prog <- runPipelineOnProgram (futharkConfig config) id file + runPolyPasses config prog + +runPolyPasses :: Config -> SOACS.Prog -> FutharkM () +runPolyPasses config prog = do + prog' <- foldM (runPolyPass pipeline_config) (SOACS prog) (getFutharkPipeline config) + case (prog', futharkAction config) of + (SOACS soacs_prog, SOACSAction action) -> + actionProcedure action soacs_prog + (Kernels kernels_prog, KernelsAction action) -> + actionProcedure action kernels_prog + (ExplicitMemory mem_prog, ExplicitMemoryAction action) -> + actionProcedure action mem_prog + + (SOACS soacs_prog, PolyAction soacs_action _ _) -> + actionProcedure soacs_action soacs_prog + (Kernels kernels_prog, PolyAction _ kernels_action _) -> + actionProcedure kernels_action kernels_prog + (ExplicitMemory mem_prog, PolyAction _ _ mem_action) -> + actionProcedure mem_action mem_prog + + (_, action) -> + externalErrorS $ "Action " <> + untypedActionName action <> + " expects " ++ representation action ++ " representation, but got " ++ + representation prog' ++ "." + where pipeline_config = + PipelineConfig { pipelineVerbose = fst (futharkVerbose $ futharkConfig config) > NotVerbose + , pipelineValidate = True + } + +runPolyPass :: PipelineConfig + -> UntypedPassState -> UntypedPass -> FutharkM UntypedPassState +runPolyPass pipeline_config s (UntypedPass f) = + f s pipeline_config diff --git a/src/Futhark/CLI/Doc.hs b/src/Futhark/CLI/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Doc.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +module Futhark.CLI.Doc (main) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State +import Data.FileEmbed +import Data.List +import System.FilePath +import System.Directory (createDirectoryIfMissing) +import System.Console.GetOpt +import System.IO +import System.Exit +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T +import Text.Blaze.Html.Renderer.Text + +import Futhark.Doc.Generator +import Futhark.Compiler (readLibrary, dumpError, newFutharkConfig, Imports, fileProg) +import Futhark.Pipeline (runFutharkM, FutharkM, Verbosity(..)) +import Language.Futhark.Syntax (progDoc, DocComment(..)) +import Futhark.Util.Options +import Futhark.Util (directoryContents, trim) + +main :: String -> [String] -> IO () +main = mainWithOptions initialDocConfig commandLineOptions "options... -o outdir programs..." f + where f [dir] config = Just $ do + res <- runFutharkM (m config dir) Verbose + case res of + Left err -> liftIO $ do + dumpError newFutharkConfig err + exitWith $ ExitFailure 2 + Right () -> + return () + f _ _ = Nothing + + m :: DocConfig -> FilePath -> FutharkM () + m config dir = + case docOutput config of + Nothing -> liftIO $ do + hPutStrLn stderr "Must specify output directory with -o." + exitWith $ ExitFailure 1 + Just outdir -> do + files <- liftIO $ futFiles dir + when (docVerbose config) $ liftIO $ do + mapM_ (hPutStrLn stderr . ("Found source file "<>)) files + hPutStrLn stderr "Reading files..." + (_w, imports, _vns) <- readLibrary files + liftIO $ printDecs config outdir files $ nubBy sameImport imports + + sameImport (x, _) (y, _) = x == y + +futFiles :: FilePath -> IO [FilePath] +futFiles dir = filter isFut <$> directoryContents dir + where isFut = (==".fut") . takeExtension + +printDecs :: DocConfig -> FilePath -> [FilePath] -> Imports -> IO () +printDecs cfg dir files imports = do + let direct_imports = map (normalise . dropExtension) files + (file_htmls, _warnings) = renderFiles direct_imports $ + filter (not . ignored) imports + mapM_ (write . fmap renderHtml) file_htmls + write ("style.css", cssFile) + + where write :: (String, T.Text) -> IO () + write (name, content) = do let file = dir makeRelative "/" name + when (docVerbose cfg) $ + hPutStrLn stderr $ "Writing " <> file + createDirectoryIfMissing True $ takeDirectory file + T.writeFile file content + + -- Some files are not worth documenting; typically because + -- they contain tests. The current crude mechanism is to + -- recognise them by a file comment containing "ignore". + ignored (_, fm) = + case progDoc (fileProg fm) of + Just (DocComment s _) -> trim s == "ignore" + _ -> False + +cssFile :: T.Text +cssFile = $(embedStringFile "rts/futhark-doc/style.css") + +data DocConfig = DocConfig { docOutput :: Maybe FilePath + , docVerbose :: Bool + } + +initialDocConfig :: DocConfig +initialDocConfig = DocConfig { docOutput = Nothing + , docVerbose = False + } + +type DocOption = OptDescr (Either (IO ()) (DocConfig -> DocConfig)) + +commandLineOptions :: [DocOption] +commandLineOptions = [ Option "o" ["output-directory"] + (ReqArg (\dirname -> Right $ \config -> config { docOutput = Just dirname }) + "DIR") + "Directory in which to put generated documentation." + , Option "v" ["verbose"] + (NoArg $ Right $ \config -> config { docVerbose = True }) + "Print status messages on stderr." + ] diff --git a/src/Futhark/CLI/Misc.hs b/src/Futhark/CLI/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Misc.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FlexibleContexts #-} +-- Various small subcommands that are too simple to deserve their own file. +module Futhark.CLI.Misc + ( mainCheck + ) +where + +import Control.Monad.State +import System.IO +import System.Exit + +import Futhark.Compiler +import Futhark.Util.Options +import Futhark.Pipeline + +runFutharkM' :: FutharkM () -> IO () +runFutharkM' m = do + res <- runFutharkM m NotVerbose + case res of + Left err -> do + dumpError newFutharkConfig err + exitWith $ ExitFailure 2 + Right () -> return () + +mainCheck :: String -> [String] -> IO () +mainCheck = mainWithOptions () [] "program" $ \args () -> + case args of + [file] -> Just $ runFutharkM' $ check file + _ -> Nothing + where check file = do (warnings, _, _) <- readProgram file + liftIO $ hPutStr stderr $ show warnings diff --git a/src/Futhark/CLI/OpenCL.hs b/src/Futhark/CLI/OpenCL.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/OpenCL.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +module Futhark.CLI.OpenCL (main) where + +import Control.Monad.IO.Class +import System.FilePath +import System.Exit +import qualified System.Info + +import Futhark.Pipeline +import Futhark.Passes +import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL +import Futhark.Util +import Futhark.Util.Pretty (prettyText) +import Futhark.Compiler.CLI + +main :: String -> [String] -> IO () +main = compilerMain () [] + "Compile OpenCL" "Generate OpenCL/C code from optimised Futhark program." + gpuPipeline $ \() mode outpath prog -> do + cprog <- either (`internalError` prettyText prog) return =<< + COpenCL.compileProg prog + let cpath = outpath `addExtension` "c" + hpath = outpath `addExtension` "h" + extra_options + | System.Info.os == "darwin" = + ["-framework", "OpenCL"] + | System.Info.os == "mingw32" = + ["-lOpenCL64"] + | otherwise = + ["-lOpenCL"] + + case mode of + ToLibrary -> do + let (header, impl) = COpenCL.asLibrary cprog + liftIO $ writeFile hpath header + liftIO $ writeFile cpath impl + ToExecutable -> do + liftIO $ writeFile cpath $ COpenCL.asExecutable cprog + ret <- liftIO $ runProgramWithExitCode "gcc" + ([cpath, "-O3", "-std=c99", "-lm", "-o", outpath] ++ extra_options) "" + case ret of + Left err -> + externalErrorS $ "Failed to run gcc: " ++ show err + Right (ExitFailure code, _, gccerr) -> + externalErrorS $ "gcc failed with code " ++ + show code ++ ":\n" ++ gccerr + Right (ExitSuccess, _, _) -> + return () diff --git a/src/Futhark/CLI/Pkg.hs b/src/Futhark/CLI/Pkg.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Pkg.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Futhark.CLI.Pkg (main) where + +import Control.Monad.IO.Class +import Control.Monad.State +import Control.Monad.Reader +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.ByteString.Lazy as LBS +import Data.List +import Data.Monoid +import System.Directory +import System.FilePath +import qualified System.FilePath.Posix as Posix +import System.Environment +import System.Exit +import System.IO +import System.Console.GetOpt + +import qualified Codec.Archive.Zip as Zip +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +import Prelude + +import Futhark.Util.Options +import Futhark.Pkg.Types +import Futhark.Pkg.Info +import Futhark.Pkg.Solve +import Futhark.Util (directoryContents) +import Futhark.Util.Log + +--- Installing packages + +installInDir :: BuildList -> FilePath -> PkgM () +installInDir (BuildList bl) dir = do + let putEntry from_dir pdir entry + -- The archive may contain all kinds of other stuff that we don't want. + | not (isInPkgDir from_dir $ Zip.eRelativePath entry) + || hasTrailingPathSeparator (Zip.eRelativePath entry) = return () + | otherwise = do + -- Since we are writing to paths indicated in a zipfile we + -- downloaded from the wild Internet, we are going to be a + -- little bit paranoid. Specifically, we want to avoid + -- writing outside of the 'lib/' directory. We do this by + -- bailing out if the path contains any '..' components. We + -- have to use System.FilePath.Posix, because the zip library + -- claims to encode filepaths with '/' directory seperators no + -- matter the host OS. + when (".." `elem` Posix.splitPath (Zip.eRelativePath entry)) $ + fail $ "Zip archive for " <> pdir <> " contains suspicious path: " <> + Zip.eRelativePath entry + let f = pdir makeRelative from_dir (Zip.eRelativePath entry) + createDirectoryIfMissing True $ takeDirectory f + LBS.writeFile f $ Zip.fromEntry entry + + isInPkgDir from_dir f = + Posix.splitPath from_dir `isPrefixOf` Posix.splitPath f + + forM_ (M.toList bl) $ \(p, v) -> do + info <- lookupPackageRev p v + a <- downloadZipball $ pkgRevZipballUrl info + m <- getManifest $ pkgRevGetManifest info + + -- Compute the directory in the zipball that should contain the + -- package files. + let noPkgDir = fail $ "futhark.pkg for " ++ T.unpack p ++ "-" ++ + T.unpack (prettySemVer v) ++ " does not define a package path." + from_dir <- maybe noPkgDir (return . (pkgRevZipballDir info <>)) $ pkgDir m + + -- The directory in the local file system that will contain the + -- package files. + let pdir = dir T.unpack p + -- Remove any existing directory for this package. This is a bit + -- inefficient, as the likelihood that the old ``lib`` directory + -- already contains the correct version is rather high. We should + -- have a way to recognise this situation, and not download the + -- zipball in that case. + liftIO $ removePathForcibly pdir + liftIO $ createDirectoryIfMissing True pdir + + liftIO $ mapM_ (putEntry from_dir pdir) $ Zip.zEntries a + +libDir, libNewDir, libOldDir :: FilePath +(libDir, libNewDir, libOldDir) = ("lib", "lib~new", "lib~old") + +-- | Install the packages listed in the build list in the 'lib' +-- directory of the current working directory. Since we are touching +-- the file system, we are going to be very paranoid. In particular, +-- we want to avoid corrupting the 'lib' directory if something fails +-- along the way. +-- +-- The procedure is as follows: +-- +-- 1) Create a directory 'lib~new'. Delete an existing 'lib~new' if +-- necessary. +-- +-- 2) Populate 'lib~new' based on the build list. +-- +-- 3) Rename 'lib' to 'lib~old'. Delete an existing 'lib~old' if +-- necessary. +-- +-- 4) Rename 'lib~new' to 'lib' +-- +-- 5) If the current package has package path 'p', move 'lib~old/p' to +-- 'lib~new/p'. +-- +-- 6) Delete 'lib~old'. +-- +-- Since POSIX at least guarantees atomic renames, the only place this +-- can fail is between steps 3, 4, and 5. In that case, at least the +-- 'lib~old' will still exist and can be put back by the user. +installBuildList :: Maybe PkgPath -> BuildList -> PkgM () +installBuildList p bl = do + libdir_exists <- liftIO $ doesDirectoryExist libDir + + -- 1 + liftIO $ do removePathForcibly libNewDir + createDirectoryIfMissing False libNewDir + + -- 2 + installInDir bl libNewDir + + -- 3 + when libdir_exists $ liftIO $ do + removePathForcibly libOldDir + renameDirectory libDir libOldDir + + -- 4 + liftIO $ renameDirectory libNewDir libDir + + -- 5 + case pkgPathFilePath <$> p of + Just pfp | libdir_exists -> liftIO $ do + pkgdir_exists <- doesDirectoryExist $ libOldDir pfp + when pkgdir_exists $ do + -- Ensure the parent directories exist so that we can move the + -- package directory directly. + createDirectoryIfMissing True $ takeDirectory $ libDir pfp + renameDirectory (libOldDir pfp) (libDir pfp) + _ -> return () + + -- 6 + when libdir_exists $ liftIO $ removePathForcibly libOldDir + +getPkgManifest :: PkgM PkgManifest +getPkgManifest = do + file_exists <- liftIO $ doesFileExist futharkPkg + dir_exists <- liftIO $ doesDirectoryExist futharkPkg + + case (file_exists, dir_exists) of + (True, _) -> liftIO $ parsePkgManifestFromFile futharkPkg + (_, True) -> fail $ futharkPkg <> + " exists, but it is a directory! What in Odin's beard..." + _ -> liftIO $ do T.putStrLn $ T.pack futharkPkg <> " not found - pretending it's empty." + return $ newPkgManifest Nothing + +putPkgManifest :: PkgManifest -> PkgM () +putPkgManifest = liftIO . T.writeFile futharkPkg . prettyPkgManifest + +--- The CLI + +newtype PkgConfig = PkgConfig { pkgVerbose :: Bool } + +-- | The monad in which futhark-pkg runs. +newtype PkgM a = PkgM { unPkgM :: ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a } + deriving (Functor, Applicative, MonadIO, MonadReader PkgConfig) + +instance Monad PkgM where + PkgM m >>= f = PkgM $ m >>= unPkgM . f + return = PkgM . return + fail s = liftIO $ do + prog <- getProgName + putStrLn $ prog ++ ": " ++ s + exitFailure + +instance MonadPkgRegistry PkgM where + putPkgRegistry = PkgM . put + getPkgRegistry = PkgM get + +instance MonadLogger PkgM where + addLog l = do + verbose <- asks pkgVerbose + when verbose $ liftIO $ T.hPutStr stderr $ toText l + +runPkgM :: PkgConfig -> PkgM a -> IO a +runPkgM cfg (PkgM m) = evalStateT (runReaderT m cfg) mempty + +cmdMain :: String -> ([String] -> PkgConfig -> Maybe (IO ())) + -> String -> [String] -> IO () +cmdMain = mainWithOptions (PkgConfig False) options + where options = [ Option "v" ["verbose"] + (NoArg $ Right $ \cfg -> cfg { pkgVerbose = True }) + "Write running diagnostics to stderr."] + +doFmt :: String -> [String] -> IO () +doFmt = mainWithOptions () [] "" $ \args () -> + case args of + [] -> Just $ do + m <- parsePkgManifestFromFile futharkPkg + T.writeFile futharkPkg $ prettyPkgManifest m + _ -> Nothing + +doCheck :: String -> [String] -> IO () +doCheck = cmdMain "check" $ \args cfg -> + case args of + [] -> Just $ runPkgM cfg $ do + m <- getPkgManifest + bl <- solveDeps $ pkgRevDeps m + + liftIO $ T.putStrLn "Dependencies chosen:" + liftIO $ T.putStr $ prettyBuildList bl + + case commented $ manifestPkgPath m of + Nothing -> return () + Just p -> do + let pdir = "lib" T.unpack p + + pdir_exists <- liftIO $ doesDirectoryExist pdir + + unless pdir_exists $ liftIO $ do + T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not exist." + exitFailure + + anything <- liftIO $ any ((==".fut") . takeExtension) <$> + directoryContents ("lib" T.unpack p) + unless anything $ liftIO $ do + T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not contain any .fut files." + exitFailure + _ -> Nothing + +doSync :: String -> [String] -> IO () +doSync = cmdMain "" $ \args cfg -> + case args of + [] -> Just $ runPkgM cfg $ do + m <- getPkgManifest + bl <- solveDeps $ pkgRevDeps m + installBuildList (commented $ manifestPkgPath m) bl + _ -> Nothing + +doAdd :: String -> [String] -> IO () +doAdd = cmdMain "PKGPATH" $ \args cfg -> + case args of + [p, v] | Right v' <- parseVersion $ T.pack v -> Just $ runPkgM cfg $ doAdd' (T.pack p) v' + [p] -> Just $ runPkgM cfg $ + -- Look up the newest revision of the package. + doAdd' (T.pack p) =<< lookupNewestRev (T.pack p) + _ -> Nothing + + where + doAdd' p v = do + m <- getPkgManifest + + -- See if this package (and its dependencies) even exists. We + -- do this by running the solver with the dependencies already + -- in the manifest, plus this new one. The Monoid instance for + -- PkgRevDeps is left-biased, so we are careful to use the new + -- version for this package. + _ <- solveDeps $ PkgRevDeps (M.singleton p (v, Nothing)) <> pkgRevDeps m + + -- We either replace any existing occurence of package 'p', or + -- we add a new one. + p_info <- lookupPackageRev p v + let hash = case (_svMajor v, _svMinor v, _svPatch v) of + -- We do not perform hash-pinning for + -- (0,0,0)-versions, because these already embed a + -- specific revision ID into their version number. + (0, 0, 0) -> Nothing + _ -> Just $ pkgRevCommit p_info + req = Required p v hash + (m', prev_r) = addRequiredToManifest req m + + case prev_r of + Just prev_r' + | requiredPkgRev prev_r' == v -> + liftIO $ T.putStrLn $ "Package already at version " <> prettySemVer v <> "; nothing to do." + | otherwise -> + liftIO $ T.putStrLn $ "Replaced " <> p <> " " <> + prettySemVer (requiredPkgRev prev_r') <> " => " <> prettySemVer v <> "." + Nothing -> + liftIO $ T.putStrLn $ "Added new required package " <> p <> " " <> prettySemVer v <> "." + putPkgManifest m' + liftIO $ T.putStrLn "Remember to run 'futhark-pkg sync'." + +doRemove :: String -> [String] -> IO () +doRemove = cmdMain "PKGPATH" $ \args cfg -> + case args of + [p] -> Just $ runPkgM cfg $ doRemove' $ T.pack p + _ -> Nothing + where + doRemove' p = do + m <- getPkgManifest + case removeRequiredFromManifest p m of + Nothing -> liftIO $ do + T.putStrLn $ "No package " <> p <> " found in " <> T.pack futharkPkg <> "." + exitFailure + Just (m', r) -> do + putPkgManifest m' + liftIO $ T.putStrLn $ "Removed " <> p <> " " <> prettySemVer (requiredPkgRev r) <> "." + +doInit :: String -> [String] -> IO () +doInit = cmdMain "PKGPATH" $ \args cfg -> + case args of + [p] -> Just $ runPkgM cfg $ doCreate' $ T.pack p + _ -> Nothing + where + doCreate' p = do + exists <- liftIO $ (||) <$> doesFileExist futharkPkg <*> doesDirectoryExist futharkPkg + when exists $ liftIO $ do + T.putStrLn $ T.pack futharkPkg <> " already exists." + exitFailure + + liftIO $ createDirectoryIfMissing True $ "lib" T.unpack p + liftIO $ T.putStrLn $ "Created directory " <> T.pack ("lib" T.unpack p) <> "." + + putPkgManifest $ newPkgManifest $ Just p + liftIO $ T.putStrLn $ "Wrote " <> T.pack futharkPkg <> "." + +doUpgrade :: String -> [String] -> IO () +doUpgrade = cmdMain "" $ \args cfg -> + case args of + [] -> Just $ runPkgM cfg $ do + m <- getPkgManifest + rs <- traverse (mapM (traverse upgrade)) $ manifestRequire m + putPkgManifest m { manifestRequire = rs } + _ -> Nothing + where upgrade req = do + v <- lookupNewestRev $ requiredPkg req + h <- pkgRevCommit <$> lookupPackageRev (requiredPkg req) v + + when (v /= requiredPkgRev req) $ + liftIO $ T.putStrLn $ "Upgraded " <> requiredPkg req <> " " <> + prettySemVer (requiredPkgRev req) <> " => " <> prettySemVer v <> "." + + return req { requiredPkgRev = v + , requiredHash = Just h } + +doVersions :: String -> [String] -> IO () +doVersions = cmdMain "PKGPATH" $ \args cfg -> + case args of + [p] -> Just $ runPkgM cfg $ doVersions' $ T.pack p + _ -> Nothing + where doVersions' = + mapM_ (liftIO . T.putStrLn . prettySemVer) . M.keys . pkgVersions + <=< lookupPackage + +main :: String -> [String] -> IO () +main prog args = do + -- Ensure that we can make HTTPS requests. + setGlobalManager =<< newManager tlsManagerSettings + + -- Avoid Git asking for credentials. We prefer failure. + liftIO $ setEnv "GIT_TERMINAL_PROMPT" "0" + + let commands = [ ("add", + (doAdd, "Add another required package to futhark.pkg.")) + , ("check", + (doCheck, "Check that futhark.pkg is satisfiable.")) + , ("init", + (doInit, "Create a new futhark.pkg and a lib/ skeleton.")) + , ("fmt", + (doFmt, "Reformat futhark.pkg.")) + , ("sync", + (doSync, "Populate lib/ as specified by futhark.pkg.")) + , ("remove", + (doRemove, "Remove a required package from futhark.pkg.")) + , ("upgrade", + (doUpgrade, "Upgrade all packages to newest versions.")) + , ("versions", + (doVersions, "List available versions for a package.")) + ] + usage = "options... <" <> intercalate "|" (map fst commands) <> ">" + case args of + cmd : args' | Just (m, _) <- lookup cmd commands -> + m (unwords [prog, cmd]) args' + _ -> do + let bad _ () = Just $ do + let k = maximum (map (length . fst) commands) + 3 + usageMsg $ T.unlines $ + [" ...:", "", "Commands:"] ++ + [ " " <> T.pack cmd <> T.pack (replicate (k - length cmd) ' ') <> desc + | (cmd, (_, desc)) <- commands ] + + mainWithOptions () [] usage bad prog args + + where usageMsg s = do + T.putStrLn $ "Usage: " <> T.pack prog <> " [--version] [--help] " <> s + exitFailure diff --git a/src/Futhark/CLI/PyOpenCL.hs b/src/Futhark/CLI/PyOpenCL.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/PyOpenCL.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} +module Futhark.CLI.PyOpenCL (main) where + +import Control.Monad.IO.Class +import System.FilePath +import System.Directory + +import Futhark.Pipeline +import Futhark.Passes +import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL +import Futhark.Util.Pretty (prettyText) +import Futhark.Compiler.CLI + +main :: String -> [String] -> IO () +main = compilerMain () [] + "Compile PyOpenCL" "Generate Python + OpenCL code from optimised Futhark program." + gpuPipeline $ \() mode outpath prog -> do + let class_name = + case mode of ToLibrary -> Just $ takeBaseName outpath + ToExecutable -> Nothing + pyprog <- either (`internalError` prettyText prog) return =<< + PyOpenCL.compileProg class_name prog + + case mode of + ToLibrary -> + liftIO $ writeFile (outpath `addExtension` "py") pyprog + ToExecutable -> liftIO $ do + writeFile outpath pyprog + perms <- liftIO $ getPermissions outpath + setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/Futhark/CLI/Python.hs b/src/Futhark/CLI/Python.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Python.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} +module Futhark.CLI.Python (main) where + +import Control.Monad.IO.Class +import System.FilePath +import System.Directory + +import Futhark.Pipeline +import Futhark.Passes +import qualified Futhark.CodeGen.Backends.SequentialPython as SequentialPy +import Futhark.Util.Pretty (prettyText) +import Futhark.Compiler.CLI + +main :: String -> [String] -> IO () +main = compilerMain () [] + "Compile sequential Python" "Generate sequential Python code from optimised Futhark program." + sequentialCpuPipeline $ \() mode outpath prog -> do + let class_name = + case mode of ToLibrary -> Just $ takeBaseName outpath + ToExecutable -> Nothing + pyprog <- either (`internalError` prettyText prog) return =<< + SequentialPy.compileProg class_name prog + + case mode of + ToLibrary -> + liftIO $ writeFile (outpath `addExtension` "py") pyprog + ToExecutable -> liftIO $ do + writeFile outpath pyprog + perms <- liftIO $ getPermissions outpath + setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/REPL.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Futhark.CLI.REPL (main) where + +import Control.Monad.Free.Church +import Control.Exception +import Data.Char +import Data.List +import Data.Loc +import Data.Maybe +import Data.Version +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.State +import Control.Monad.Except +import qualified Data.Text as T +import qualified Data.Text.IO as T +import NeatInterpolation (text) +import System.Directory +import System.FilePath +import System.Console.GetOpt +import System.IO +import qualified System.Console.Haskeline as Haskeline + +import Language.Futhark +import Language.Futhark.Parser hiding (EOF) +import qualified Language.Futhark.TypeChecker as T +import qualified Language.Futhark.Semantic as T +import Futhark.MonadFreshNames +import Futhark.Version +import Futhark.Compiler +import Futhark.Pipeline +import Futhark.Util.Options +import Futhark.Util (toPOSIX, maybeHead) + +import qualified Language.Futhark.Interpreter as I + +banner :: String +banner = unlines [ + "|// |\\ | |\\ |\\ /", + "|/ | \\ |\\ |\\ |/ /", + "| | \\ |/ | |\\ \\", + "| | \\ | | | \\ \\" + ] + +main :: String -> [String] -> IO () +main = mainWithOptions interpreterConfig options "options..." run + where run [] _ = Just repl + run _ _ = Nothing + +data StopReason = EOF | Stop | Exit | Load FilePath + +repl :: IO () +repl = do + putStr banner + putStrLn $ "Version " ++ showVersion version ++ "." + putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license." + putStrLn "" + putStrLn "Run :help for a list of commands." + putStrLn "" + + let toploop s = do + (stop, s') <- runStateT (runExceptT $ runFutharkiM $ forever readEvalPrint) s + case stop of + Left Stop -> finish s' + Left EOF -> finish s' + Left Exit -> finish s' + Left (Load file) -> do + liftIO $ T.putStrLn $ "Loading " <> T.pack file + maybe_new_state <- + liftIO $ newFutharkiState (futharkiCount s) $ Just file + case maybe_new_state of + Right new_state -> toploop new_state + Left err -> do liftIO $ putStrLn err + toploop s' + Right _ -> return () + + finish s = do + quit <- confirmQuit + if quit then return () else toploop s + + maybe_init_state <- liftIO $ newFutharkiState 0 Nothing + case maybe_init_state of + Left err -> error $ "Failed to initialise intepreter state: " ++ err + Right init_state -> Haskeline.runInputT Haskeline.defaultSettings $ toploop init_state + + putStrLn "Leaving futharki." + +confirmQuit :: Haskeline.InputT IO Bool +confirmQuit = do + c <- Haskeline.getInputChar "Quit futharki? (y/n) " + case c of + Nothing -> return True -- EOF + Just 'y' -> return True + Just 'n' -> return False + _ -> confirmQuit + +newtype InterpreterConfig = InterpreterConfig { interpreterEntryPoint :: Name } + +interpreterConfig :: InterpreterConfig +interpreterConfig = InterpreterConfig defaultEntryPoint + +options :: [FunOptDescr InterpreterConfig] +options = [ Option "e" ["entry-point"] + (ReqArg (\entry -> Right $ \config -> + config { interpreterEntryPoint = nameFromString entry }) + "NAME") + "The entry point to execute." + ] + +data FutharkiState = + FutharkiState { futharkiImports :: Imports + , futharkiNameSource :: VNameSource + , futharkiCount :: Int + , futharkiEnv :: (T.Env, I.Ctx) + , futharkiBreaking :: Maybe Loc + -- ^ Are we currently stopped at a breakpoint? + , futharkiSkipBreaks :: [Loc] + -- ^ Skip breakpoints at these locations. + , futharkiLoaded :: Maybe FilePath + -- ^ The currently loaded file. + } + +newFutharkiState :: Int -> Maybe FilePath -> IO (Either String FutharkiState) +newFutharkiState count maybe_file = runExceptT $ do + (imports, src, tenv, ienv) <- case maybe_file of + + Nothing -> do + -- Load the builtins through the type checker. + (_, imports, src) <- badOnLeft =<< runExceptT (readLibrary []) + -- Then into the interpreter. + ienv <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) + I.initialCtx $ map (fmap fileProg) imports + + -- Then make the prelude available in the type checker. + (tenv, d, src') <- badOnLeft $ T.checkDec imports src T.initialEnv + (T.mkInitialImport ".") $ mkOpen "/futlib/prelude" + -- Then in the interpreter. + ienv' <- badOnLeft =<< runInterpreter' (I.interpretDec ienv d) + return (imports, src', tenv, ienv') + + Just file -> do + (ws, imports, src) <- + badOnLeft =<< liftIO (runExceptT (readProgram file) + `Haskeline.catch` \(err::IOException) -> + return (Left (ExternalError (T.pack $ show err)))) + liftIO $ hPrint stderr ws + + let imp = T.mkInitialImport "." + ienv1 <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $ + map (fmap fileProg) imports + (tenv1, d1, src') <- badOnLeft $ T.checkDec imports src T.initialEnv imp $ + mkOpen "/futlib/prelude" + (tenv2, d2, src'') <- badOnLeft $ T.checkDec imports src' tenv1 imp $ + mkOpen $ toPOSIX $ dropExtension file + ienv2 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv1 d1) + ienv3 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv2 d2) + return (imports, src'', tenv2, ienv3) + + return FutharkiState { futharkiImports = imports + , futharkiNameSource = src + , futharkiCount = count + , futharkiEnv = (tenv, ienv) + , futharkiBreaking = Nothing + , futharkiSkipBreaks = mempty + , futharkiLoaded = maybe_file + } + where badOnLeft :: Show err => Either err a -> ExceptT String IO a + badOnLeft (Right x) = return x + badOnLeft (Left err) = throwError $ show err + +getPrompt :: FutharkiM String +getPrompt = do + i <- gets futharkiCount + return $ "[" ++ show i ++ "]> " + +mkOpen :: FilePath -> UncheckedDec +mkOpen f = OpenDec (ModImport f NoInfo noLoc) noLoc + +-- The ExceptT part is more of a continuation, really. +newtype FutharkiM a = + FutharkiM { runFutharkiM :: ExceptT StopReason (StateT FutharkiState (Haskeline.InputT IO)) a } + deriving (Functor, Applicative, Monad, + MonadState FutharkiState, MonadIO, MonadError StopReason) + +readEvalPrint :: FutharkiM () +readEvalPrint = do + prompt <- getPrompt + line <- inputLine prompt + breaking <- gets futharkiBreaking + case T.uncons line of + Nothing + | isJust breaking -> throwError Stop + | otherwise -> return () + + Just (':', command) -> do + let (cmdname, rest) = T.break isSpace command + arg = T.dropWhileEnd isSpace $ T.dropWhile isSpace rest + case filter ((cmdname `T.isPrefixOf`) . fst) commands of + [] -> liftIO $ T.putStrLn $ "Unknown command '" <> cmdname <> "'" + [(_, (cmdf, _))] -> cmdf arg + matches -> liftIO $ T.putStrLn $ "Ambiguous command; could be one of " <> + mconcat (intersperse ", " (map fst matches)) + + _ -> do + -- Read a declaration or expression. + maybe_dec_or_e <- parseDecOrExpIncrM (inputLine " ") prompt line + + case maybe_dec_or_e of + Left err -> liftIO $ print err + Right (Left d) -> onDec d + Right (Right e) -> onExp e + modify $ \s -> s { futharkiCount = futharkiCount s + 1 } + where inputLine prompt = do + inp <- FutharkiM $ lift $ lift $ Haskeline.getInputLine prompt + case inp of + Just s -> return $ T.pack s + Nothing -> throwError EOF + +getIt :: FutharkiM (Imports, VNameSource, T.Env, I.Ctx) +getIt = do + imports <- gets futharkiImports + src <- gets futharkiNameSource + (tenv, ienv) <- gets futharkiEnv + return (imports, src, tenv, ienv) + +onDec :: UncheckedDec -> FutharkiM () +onDec d = do + (imports, src, tenv, ienv) <- getIt + cur_import <- T.mkInitialImport . fromMaybe "." <$> gets futharkiLoaded + + -- Most of the complexity here concerns the dealing with the fact + -- that 'import "foo"' is a declaration. We have to involve a lot + -- of machinery to load this external code before executing the + -- declaration itself. + let basis = Basis imports src ["/futlib/prelude"] + mkImport = uncurry $ T.mkImportFrom cur_import + imp_r <- runExceptT $ readImports basis (map mkImport $ decImports d) + + case imp_r of + Left e -> liftIO $ print e + Right (_, imports', src') -> + case T.checkDec imports' src' tenv cur_import d of + Left e -> liftIO $ print e + Right (tenv', d', src'') -> do + let new_imports = filter ((`notElem` map fst imports) . fst) imports' + int_r <- runInterpreter $ do + let onImport ienv' (s, imp) = + I.interpretImport ienv' (s, T.fileProg imp) + ienv' <- foldM onImport ienv new_imports + I.interpretDec ienv' d' + case int_r of + Left err -> liftIO $ print err + Right ienv' -> modify $ \s -> s { futharkiEnv = (tenv', ienv') + , futharkiImports = imports' + , futharkiNameSource = src'' + } + +onExp :: UncheckedExp -> FutharkiM () +onExp e = do + (imports, src, tenv, ienv) <- getIt + case showErr (T.checkExp imports src tenv e) of + Left err -> liftIO $ putStrLn err + Right (_, e') -> do + r <- runInterpreter $ I.interpretExp ienv e' + case r of + Left err -> liftIO $ print err + Right v -> liftIO $ putStrLn $ pretty v + where showErr :: Show a => Either a b -> Either String b + showErr = either (Left . show) Right + +runInterpreter :: F I.ExtOp a -> FutharkiM (Either I.InterpreterError a) +runInterpreter m = runF m (return . Right) intOp + where + intOp (I.ExtOpError err) = + return $ Left err + intOp (I.ExtOpTrace w v c) = do + liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v + c + intOp (I.ExtOpBreak w ctx tenv c) = do + s <- get + + -- Are we supposed to skip this breakpoint? + let loc = maybe noLoc locOf $ maybeHead w + + -- We do not want recursive breakpoints. It could work fine + -- technically, but is probably too confusing to be useful. + unless (isJust (futharkiBreaking s) || loc `elem` futharkiSkipBreaks s) $ do + liftIO $ putStrLn $ "Breaking at " ++ intercalate " -> " (map locStr w) ++ "." + liftIO $ putStrLn " to continue." + + -- Note the cleverness to preserve the Haskeline session (for + -- line history and such). + (stop, s') <- + FutharkiM $ lift $ lift $ + runStateT (runExceptT $ runFutharkiM $ forever readEvalPrint) + s { futharkiEnv = (tenv, ctx) + , futharkiCount = futharkiCount s + 1 + , futharkiBreaking = Just loc } + + case stop of + Left (Load file) -> throwError $ Load file + _ -> do liftIO $ putStrLn "Continuing..." + put s { futharkiCount = futharkiCount s' + , futharkiSkipBreaks = futharkiSkipBreaks s' <> futharkiSkipBreaks s } + + c + +runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) +runInterpreter' m = runF m (return . Right) intOp + where intOp (I.ExtOpError err) = return $ Left err + intOp (I.ExtOpTrace w v c) = do + liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v + c + intOp (I.ExtOpBreak _ _ _ c) = c + +type Command = T.Text -> FutharkiM () + +loadCommand :: Command +loadCommand file = do + loaded <- gets futharkiLoaded + case (T.null file, loaded) of + (True, Just loaded') -> throwError $ Load loaded' + (True, Nothing) -> liftIO $ T.putStrLn "No file specified and no file previously loaded." + (False, _) -> throwError $ Load $ T.unpack file + +genTypeCommand :: (Show err1, Show err2) => + (String -> T.Text -> Either err1 a) + -> (Imports -> VNameSource -> T.Env -> a -> Either err2 b) + -> (b -> String) + -> Command +genTypeCommand f g h e = do + prompt <- getPrompt + case f prompt e of + Left err -> liftIO $ print err + Right e' -> do + imports <- gets futharkiImports + src <- gets futharkiNameSource + (tenv, _) <- gets futharkiEnv + case g imports src tenv e' of + Left err -> liftIO $ print err + Right x -> liftIO $ putStrLn $ h x + +typeCommand :: Command +typeCommand = genTypeCommand parseExp T.checkExp $ \(ps, e) -> + pretty e <> concatMap ((" "<>) . pretty) ps <> + " : " <> pretty (typeOf e) + +mtypeCommand :: Command +mtypeCommand = genTypeCommand parseModExp T.checkModExp $ pretty . fst + +unbreakCommand :: Command +unbreakCommand _ = do + breaking <- gets futharkiBreaking + case breaking of + Nothing -> liftIO $ putStrLn "Not currently stopped at a breakpoint." + Just loc -> do modify $ \s -> s { futharkiSkipBreaks = loc : futharkiSkipBreaks s } + throwError Stop + +pwdCommand :: Command +pwdCommand _ = liftIO $ putStrLn =<< getCurrentDirectory + +cdCommand :: Command +cdCommand dir + | T.null dir = liftIO $ putStrLn "Usage: ':cd '." + | otherwise = + liftIO $ setCurrentDirectory (T.unpack dir) + `Haskeline.catch` \(err::IOException) -> print err + +helpCommand :: Command +helpCommand _ = liftIO $ forM_ commands $ \(cmd, (_, desc)) -> do + T.putStrLn $ ":" <> cmd + T.putStrLn $ T.replicate (1+T.length cmd) "-" + T.putStr desc + T.putStrLn "" + T.putStrLn "" + +quitCommand :: Command +quitCommand _ = throwError Exit + +commands :: [(T.Text, (Command, T.Text))] +commands = [("load", (loadCommand, [text| +Load a Futhark source file. Usage: + + > :load foo.fut + +If the loading succeeds, any subsequentialy entered expressions entered +subsequently will have access to the definition (such as function definitions) +in the source file. + +Only one source file can be loaded at a time. Using the :load command a +second time will replace the previously loaded file. It will also replace +any declarations entered at the REPL. + +|])), + ("type", (typeCommand, [text| +Show the type of an expression, which must fit on a single line. +|])), + ("mtype", (mtypeCommand, [text| +Show the type of a module expression, which must fit on a single line. +|])), + ("unbreak", (unbreakCommand, [text| +Skip all future occurences of the current breakpoint. +|])), + ("pwd", (pwdCommand, [text| +Print the current working directory. +|])), + ("cd", (cdCommand, [text| +Change the current working directory. +|])), + ("help", (helpCommand, [text| +Print a list of commands and a description of their behaviour. +|])), + ("quit", (quitCommand, [text| +Quit futharki. +|]))] diff --git a/src/Futhark/CLI/Run.hs b/src/Futhark/CLI/Run.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Run.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Futhark.CLI.Run (main) where + +import Control.Monad.Free.Church +import Control.Exception +import Data.Array +import Data.List +import Data.Loc +import Data.Maybe +import qualified Data.Map as M +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Except +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.FilePath +import System.Exit +import System.Console.GetOpt +import System.IO +import qualified System.Console.Haskeline as Haskeline + +import Prelude + +import Language.Futhark +import Language.Futhark.Parser hiding (EOF) +import qualified Language.Futhark.TypeChecker as T +import qualified Language.Futhark.Semantic as T +import Futhark.Compiler +import Futhark.Pipeline +import Futhark.Util.Options +import Futhark.Util (toPOSIX) + +import qualified Language.Futhark.Interpreter as I + +main :: String -> [String] -> IO () +main = mainWithOptions interpreterConfig options "options... program" run + where run [prog] config = Just $ interpret config prog + run _ _ = Nothing + +interpret :: InterpreterConfig -> FilePath -> IO () +interpret config fp = do + pr <- newFutharkiState config fp + (tenv, ienv) <- case pr of Left err -> do hPutStrLn stderr err + exitFailure + Right env -> return env + + let entry = interpreterEntryPoint config + vr <- parseValues "stdin" <$> T.getContents + + inps <- + case vr of + Left err -> do + hPutStrLn stderr $ "Error when reading input: " ++ show err + exitFailure + Right vs + | Just vs' <- mapM convertValue vs -> + return vs' + | otherwise -> do + hPutStrLn stderr "Error when reading input: irregular array." + exitFailure + + (fname, ret) <- + case M.lookup (T.Term, entry) $ T.envNameMap tenv of + Just fname + | Just (T.BoundV _ t) <- M.lookup (qualLeaf fname) $ T.envVtable tenv -> + return (fname, toStructural $ snd $ unfoldFunType t) + _ -> do hPutStrLn stderr $ "Invalid entry point: " ++ pretty entry + exitFailure + + r <- runInterpreter' $ I.interpretFunction ienv (qualLeaf fname) inps + case r of + Left err -> do hPrint stderr err + exitFailure + Right res -> + case (I.fromTuple res, isTupleRecord ret) of + (Just vs, Just ts) -> zipWithM_ putValue vs ts + _ -> putValue res ret + +putValue :: I.Value -> TypeBase () () -> IO () +putValue v t + | I.isEmptyArray v = + putStrLn $ "empty(" ++ pretty (stripArray 1 t) ++ ")" + | otherwise = putStrLn $ pretty v + +convertValue :: Value -> Maybe I.Value +convertValue (PrimValue p) = Just $ I.ValuePrim p +convertValue (ArrayValue arr _) = I.mkArray =<< mapM convertValue (elems arr) + +data InterpreterConfig = + InterpreterConfig { interpreterEntryPoint :: Name + , interpreterPrintWarnings :: Bool + } + +interpreterConfig :: InterpreterConfig +interpreterConfig = InterpreterConfig defaultEntryPoint True + +options :: [FunOptDescr InterpreterConfig] +options = [ Option "e" ["entry-point"] + (ReqArg (\entry -> Right $ \config -> + config { interpreterEntryPoint = nameFromString entry }) + "NAME") + "The entry point to execute." + , Option "w" ["no-warnings"] + (NoArg $ Right $ \config -> config { interpreterPrintWarnings = False }) + "Do not print warnings." + ] + +newFutharkiState :: InterpreterConfig -> FilePath + -> IO (Either String (T.Env, I.Ctx)) +newFutharkiState cfg file = runExceptT $ do + (ws, imports, src) <- + badOnLeft =<< liftIO (runExceptT (readProgram file) + `Haskeline.catch` \(err::IOException) -> + return (Left (ExternalError (T.pack $ show err)))) + when (interpreterPrintWarnings cfg) $ + liftIO $ hPrint stderr ws + + let imp = T.mkInitialImport "." + ienv1 <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $ + map (fmap fileProg) imports + (tenv1, d1, src') <- badOnLeft $ T.checkDec imports src T.initialEnv imp $ + mkOpen "/futlib/prelude" + (tenv2, d2, _) <- badOnLeft $ T.checkDec imports src' tenv1 imp $ + mkOpen $ toPOSIX $ dropExtension file + ienv2 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv1 d1) + ienv3 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv2 d2) + return (tenv2, ienv3) + where badOnLeft :: Show err => Either err a -> ExceptT String IO a + badOnLeft (Right x) = return x + badOnLeft (Left err) = throwError $ show err + +mkOpen :: FilePath -> UncheckedDec +mkOpen f = OpenDec (ModImport f NoInfo noLoc) noLoc + +runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) +runInterpreter' m = runF m (return . Right) intOp + where intOp (I.ExtOpError err) = return $ Left err + intOp (I.ExtOpTrace w v c) = do + liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v + c + intOp (I.ExtOpBreak _ _ _ c) = c diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CLI/Test.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts, LambdaCase #-} +-- | This program is a convenience utility for running the Futhark +-- test suite, and its test programs. +module Futhark.CLI.Test (main) where + +import Control.Applicative.Lift (runErrors, failure, Errors, Lift(..)) +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Except hiding (throwError) +import qualified Control.Monad.Except as E +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Lazy as LBS + +import Data.List +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import System.Console.ANSI +import System.Process.ByteString (readProcessWithExitCode) +import System.Exit +import System.FilePath +import System.Console.GetOpt +import System.IO +import Text.Regex.TDFA + +import Futhark.Analysis.Metrics +import Futhark.Test +import Futhark.Util.Options +import Futhark.Util.Pretty (prettyText) +import Futhark.Util.Table + +--- Test execution + +type TestM = ExceptT [T.Text] IO + +-- Taken from transformers-0.5.5.0. +eitherToErrors :: Either e a -> Errors e a +eitherToErrors = either failure Pure + +throwError :: MonadError [e] m => e -> m a +throwError e = E.throwError [e] + +runTestM :: TestM () -> IO TestResult +runTestM = fmap (either Failure $ const Success) . runExceptT + +io :: IO a -> TestM a +io = liftIO + +context :: T.Text -> TestM a -> TestM a +context s = withExceptT $ + \case + [] -> [] + (e:es') -> (s <> ":\n" <> e):es' + +accErrors :: [TestM a] -> TestM [a] +accErrors tests = do + eithers <- lift $ mapM runExceptT tests + let errors = traverse eitherToErrors eithers + ExceptT $ return $ runErrors errors + +accErrors_ :: [TestM a] -> TestM () +accErrors_ = void . accErrors + +data TestResult = Success + | Failure [T.Text] + deriving (Eq, Show) + +data TestCase = TestCase { _testCaseMode :: TestMode + , testCaseProgram :: FilePath + , testCaseTest :: ProgramTest + , _testCasePrograms :: ProgConfig + } + deriving (Show) + +instance Eq TestCase where + x == y = testCaseProgram x == testCaseProgram y + +instance Ord TestCase where + x `compare` y = testCaseProgram x `compare` testCaseProgram y + +data RunResult = ErrorResult Int SBS.ByteString + | SuccessResult [Value] + +progNotFound :: T.Text -> T.Text +progNotFound s = s <> ": command not found" + +optimisedProgramMetrics :: ProgConfig -> StructurePipeline -> FilePath -> TestM AstMetrics +optimisedProgramMetrics programs pipeline program = + case pipeline of SOACSPipeline -> + check "-s" + KernelsPipeline -> + check "--kernels" + SequentialCpuPipeline -> + check "--cpu" + GpuPipeline -> + check "--gpu" + where check opt = do + (code, output, err) <- + io $ readProcessWithExitCode (configFuthark programs) ["dev", opt, "--metrics", program] "" + let output' = T.decodeUtf8 output + case code of + ExitSuccess + | [(m, [])] <- reads $ T.unpack output' -> return m + | otherwise -> throwError $ "Could not read metrics output:\n" <> output' + ExitFailure 127 -> throwError $ progNotFound $ T.pack $ configFuthark programs + ExitFailure _ -> throwError $ T.decodeUtf8 err + +testMetrics :: ProgConfig -> FilePath -> StructureTest -> TestM () +testMetrics programs program (StructureTest pipeline (AstMetrics expected)) = + context "Checking metrics" $ do + actual <- optimisedProgramMetrics programs pipeline program + accErrors_ $ map (ok actual) $ M.toList expected + where ok (AstMetrics metrics) (name, expected_occurences) = + case M.lookup name metrics of + Nothing + | expected_occurences > 0 -> + throwError $ name <> " should have occurred " <> T.pack (show expected_occurences) <> + " times, but did not occur at all in optimised program." + Just actual_occurences + | expected_occurences /= actual_occurences -> + throwError $ name <> " should have occurred " <> T.pack (show expected_occurences) <> + " times, but occured " <> T.pack (show actual_occurences) <> " times." + _ -> return () + +testWarnings :: [WarningTest] -> SBS.ByteString -> TestM () +testWarnings warnings futerr = accErrors_ $ map testWarning warnings + where testWarning (ExpectedWarning regex_s regex) + | not (match regex $ T.unpack $ T.decodeUtf8 futerr) = + throwError $ "Expected warning:\n " <> regex_s <> + "\nGot warnings:\n " <> T.decodeUtf8 futerr + | otherwise = return () + +runTestCase :: TestCase -> TestM () +runTestCase (TestCase mode program testcase progs) = + case testAction testcase of + + CompileTimeFailure expected_error -> + context (mconcat ["Type-checking with '", T.pack futhark, + " check ", T.pack program, "'"]) $ do + (code, _, err) <- + io $ readProcessWithExitCode futhark ["check", program] "" + case code of + ExitSuccess -> throwError "Expected failure\n" + ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark + ExitFailure 1 -> throwError $ T.decodeUtf8 err + ExitFailure _ -> checkError expected_error err + + RunCases _ _ warnings | mode == TypeCheck -> do + let options = ["check", program] ++ configExtraCompilerOptions progs + context (mconcat ["Type-checking with '", T.pack futhark, + " check ", T.pack program, "'"]) $ do + (code, _, err) <- io $ readProcessWithExitCode futhark options "" + testWarnings warnings err + case code of + ExitSuccess -> return () + ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark + ExitFailure _ -> throwError $ T.decodeUtf8 err + + RunCases ios structures warnings -> do + -- Compile up-front and reuse same executable for several entry points. + let backend = configBackend progs + extra_options = configExtraCompilerOptions progs + unless (mode == Compile) $ + context "Generating reference outputs" $ + ensureReferenceOutput futhark "c" program ios + unless (mode == Interpreted) $ + context ("Compiling with --backend=" <> T.pack backend) $ do + compileTestProgram extra_options futhark backend program warnings + mapM_ (testMetrics progs program) structures + unless (mode == Compile) $ + context "Running compiled program" $ + accErrors_ $ map (runCompiledEntry program progs) ios + unless (mode == Compile || mode == Compiled) $ + context "Interpreting" $ + accErrors_ $ map (runInterpretedEntry futhark program) ios + where futhark = configFuthark progs + +runInterpretedEntry :: String -> FilePath -> InputOutputs -> TestM() +runInterpretedEntry futhark program (InputOutputs entry run_cases) = + let dir = takeDirectory program + runInterpretedCase run@(TestRun _ inputValues _ index _) = + unless ("compiled" `elem` runTags run) $ + context ("Entry point: " <> entry + <> "; dataset: " <> T.pack (runDescription run)) $ do + + input <- T.unlines . map prettyText <$> getValues dir inputValues + expectedResult' <- getExpectedResult program entry run + (code, output, err) <- + io $ readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $ + T.encodeUtf8 input + case code of + ExitFailure 127 -> throwError $ progNotFound $ T.pack futhark + + _ -> compareResult entry index program expectedResult' + =<< runResult program code output err + + in accErrors_ $ map runInterpretedCase run_cases + +runCompiledEntry :: FilePath -> ProgConfig -> InputOutputs -> TestM () +runCompiledEntry program progs (InputOutputs entry run_cases) = + -- Explicitly prefixing the current directory is necessary for + -- readProcessWithExitCode to find the binary when binOutputf has + -- no path component. + let binOutputf = dropExtension program + binpath = "." binOutputf + entry_options = ["-e", T.unpack entry] + + runner = configRunner progs + extra_options = configExtraOptions progs + + runCompiledCase run@(TestRun _ inputValues _ index _) = + context ("Entry point: " <> entry + <> "; dataset: " <> T.pack (runDescription run)) $ do + expected <- getExpectedResult program entry run + (progCode, output, progerr) <- + runProgram runner extra_options program entry inputValues + compareResult entry index program expected + =<< runResult program progCode output progerr + + in context ("Running " <> T.pack (unwords $ binpath : entry_options ++ extra_options)) $ + accErrors_ $ map runCompiledCase run_cases + +checkError :: ExpectedError -> SBS.ByteString -> TestM () +checkError (ThisError regex_s regex) err + | not (match regex $ T.unpack $ T.decodeUtf8 err) = + throwError $ "Expected error:\n " <> regex_s <> + "\nGot error:\n " <> T.decodeUtf8 err +checkError _ _ = + return () + +runResult :: FilePath -> ExitCode -> SBS.ByteString -> SBS.ByteString -> TestM RunResult +runResult program ExitSuccess stdout_s _ = + case valuesFromByteString "stdout" $ LBS.fromStrict stdout_s of + Left e -> do + let actualf = program `addExtension` "actual" + io $ SBS.writeFile actualf stdout_s + throwError $ T.pack e <> "\n(See " <> T.pack actualf <> ")" + Right vs -> return $ SuccessResult vs +runResult _ (ExitFailure code) _ stderr_s = + return $ ErrorResult code stderr_s + +compileTestProgram :: [String] -> FilePath -> String -> FilePath -> [WarningTest] -> TestM () +compileTestProgram extra_options futhark backend program warnings = do + (_, futerr) <- compileProgram extra_options futhark backend program + testWarnings warnings futerr + +compareResult :: T.Text -> Int -> FilePath -> ExpectedResult [Value] -> RunResult + -> TestM () +compareResult _ _ _ (Succeeds Nothing) SuccessResult{} = + return () +compareResult entry index program (Succeeds (Just expectedResult)) (SuccessResult actualResult) = + case compareValues1 actualResult expectedResult of + Just mismatch -> do + let actualf = program <.> T.unpack entry <.> show index <.> "actual" + expectedf = program <.> T.unpack entry <.> show index <.> "expected" + io $ SBS.writeFile actualf $ + T.encodeUtf8 $ T.unlines $ map prettyText actualResult + io $ SBS.writeFile expectedf $ + T.encodeUtf8 $ T.unlines $ map prettyText expectedResult + throwError $ T.pack actualf <> " and " <> T.pack expectedf <> + " do not match:\n" <> T.pack (show mismatch) <> "\n" + Nothing -> + return () +compareResult _ _ _ (RunTimeFailure expectedError) (ErrorResult _ actualError) = + checkError expectedError actualError +compareResult _ _ _ (Succeeds _) (ErrorResult code err) = + throwError $ "Program failed with error code " <> + T.pack (show code) <> " and stderr:\n " <> T.decodeUtf8 err +compareResult _ _ _ (RunTimeFailure f) (SuccessResult _) = + throwError $ "Program succeeded, but expected failure:\n " <> T.pack (show f) + +--- +--- Test manager +--- + +data TestStatus = TestStatus { testStatusRemain :: [TestCase] + , testStatusRun :: [TestCase] + , testStatusTotal :: Int + , testStatusFail :: Int + , testStatusPass :: Int + , testStatusRuns :: Int + , testStatusRunsRemain :: Int + , testStatusRunPass :: Int + , testStatusRunFail :: Int + } + +catching :: IO TestResult -> IO TestResult +catching m = m `catch` save + where save :: SomeException -> IO TestResult + save e = return $ Failure [T.pack $ show e] + +doTest :: TestCase -> IO TestResult +doTest = catching . runTestM . runTestCase + +makeTestCase :: TestConfig -> TestMode -> (FilePath, ProgramTest) -> TestCase +makeTestCase config mode (file, spec) = + TestCase mode file spec $ configPrograms config + +data ReportMsg = TestStarted TestCase + | TestDone TestCase TestResult + +runTest :: MVar TestCase -> MVar ReportMsg -> IO () +runTest testmvar resmvar = forever $ do + test <- takeMVar testmvar + putMVar resmvar $ TestStarted test + res <- doTest test + putMVar resmvar $ TestDone test res + +excludedTest :: TestConfig -> TestCase -> Bool +excludedTest config = + any (`elem` configExclude config) . testTags . testCaseTest + +statusTable :: TestStatus -> String +statusTable ts = buildTable rows 1 + where rows = + [ [ mkEntry "", passed, failed, mkEntry "remaining"] + , map mkEntry ["programs", passedProgs, failedProgs, remainProgs'] + , map mkEntry ["runs", passedRuns, failedRuns, remainRuns'] + ] + passed = ("passed", [SetColor Foreground Vivid Green]) + failed = ("failed", [SetColor Foreground Vivid Red]) + passedProgs = show $ testStatusPass ts + failedProgs = show $ testStatusFail ts + totalProgs = show $ testStatusTotal ts + totalRuns = show $ testStatusRuns ts + passedRuns = show $ testStatusRunPass ts + failedRuns = show $ testStatusRunFail ts + remainProgs = show . length $ testStatusRemain ts + remainProgs' = remainProgs ++ "/" ++ totalProgs + remainRuns = show $ testStatusRunsRemain ts + remainRuns' = remainRuns ++ "/" ++ totalRuns + +tableLines :: Int +tableLines = 1 + (length . lines $ blankTable) + where blankTable = statusTable $ TestStatus [] [] 0 0 0 0 0 0 0 + +spaceTable :: IO () +spaceTable = putStr $ replicate tableLines '\n' + +reportTable :: TestStatus -> IO () +reportTable ts = do + moveCursorToTableTop + putStrLn $ statusTable ts + clearLine + putStrLn $ atMostChars 60 running + where running = "Now testing: " ++ + (unwords . reverse . map testCaseProgram . testStatusRun) ts + +moveCursorToTableTop :: IO () +moveCursorToTableTop = cursorUpLine tableLines + +atMostChars :: Int -> String -> String +atMostChars n s | length s > n = take (n-3) s ++ "..." + | otherwise = s + +reportText :: TestStatus -> IO () +reportText ts = + putStr $ "(" ++ show (testStatusFail ts) ++ " failed, " ++ + show (testStatusPass ts) ++ " passed, " ++ + show num_remain ++ " to go).\n" + where num_remain = length $ testStatusRemain ts + +runTests :: TestConfig -> [FilePath] -> IO () +runTests config paths = do + -- We force line buffering to ensure that we produce running output. + -- Otherwise, CI tools and the like may believe we are hung and kill + -- us. + hSetBuffering stdout LineBuffering + + let mode = configTestMode config + all_tests <- map (makeTestCase config mode) <$> testSpecsFromPaths paths + testmvar <- newEmptyMVar + reportmvar <- newEmptyMVar + concurrency <- getNumCapabilities + replicateM_ concurrency $ forkIO $ runTest testmvar reportmvar + + let (excluded, included) = partition (excludedTest config) all_tests + _ <- forkIO $ mapM_ (putMVar testmvar) included + isTTY <- (&& not (configLineOutput config)) <$> hIsTerminalDevice stdout + + let report = if isTTY then reportTable else reportText + clear = if isTTY then clearFromCursorToScreenEnd else putStr "\n" + + numTestCases tc = + case testAction $ testCaseTest tc of + CompileTimeFailure _ -> 1 + RunCases ios sts wts -> (length . concat) (iosTestRuns <$> ios) + + length sts + length wts + + getResults ts + | null (testStatusRemain ts) = report ts >> return ts + | otherwise = do + report ts + msg <- takeMVar reportmvar + case msg of + TestStarted test -> do + unless isTTY $ + putStr $ "Started testing " <> testCaseProgram test <> " " + getResults $ ts {testStatusRun = test : testStatusRun ts} + TestDone test res -> do + let ts' = ts { testStatusRemain = test `delete` testStatusRemain ts + , testStatusRun = test `delete` testStatusRun ts + , testStatusRunsRemain = testStatusRunsRemain ts + - numTestCases test + } + case res of + Success -> do + let ts'' = ts' { testStatusRunPass = + testStatusRunPass ts' + numTestCases test + } + unless isTTY $ + putStr $ "Finished testing " <> testCaseProgram test <> " " + getResults $ ts'' { testStatusPass = testStatusPass ts + 1} + Failure s -> do + when isTTY moveCursorToTableTop + clear + T.putStr $ (T.pack (inRed $ testCaseProgram test) <> ":\n") <> T.unlines s + when isTTY spaceTable + getResults $ ts' { testStatusFail = testStatusFail ts' + 1 + , testStatusRunPass = testStatusRunPass ts' + + numTestCases test - length s + + , testStatusRunFail = testStatusRunFail ts' + + length s + } + + when isTTY spaceTable + + ts <- getResults TestStatus { testStatusRemain = included + , testStatusRun = [] + , testStatusTotal = length included + , testStatusFail = 0 + , testStatusPass = 0 + , testStatusRuns = sum $ map numTestCases included + , testStatusRunsRemain = sum $ map numTestCases included + , testStatusRunPass = 0 + , testStatusRunFail = 0 + } + + -- Removes "Now testing" output. + when isTTY $ cursorUpLine 1 >> clearLine + + let excluded_str = if null excluded + then "" + else " (" ++ show (length excluded) ++ " program(s) excluded).\n" + putStr excluded_str + exitWith $ case testStatusFail ts of 0 -> ExitSuccess + _ -> ExitFailure 1 + +inRed :: String -> String +inRed s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset] + +--- +--- Configuration and command line parsing +--- + +data TestConfig = TestConfig + { configTestMode :: TestMode + , configPrograms :: ProgConfig + , configExclude :: [T.Text] + , configLineOutput :: Bool + } + +defaultConfig :: TestConfig +defaultConfig = TestConfig { configTestMode = Everything + , configExclude = [ "disable" ] + , configPrograms = + ProgConfig + { configBackend = "c" + , configFuthark = "futhark" + , configRunner = "" + , configExtraOptions = [] + , configExtraCompilerOptions = [] + } + , configLineOutput = False + } + +data ProgConfig = ProgConfig + { configBackend :: String + , configFuthark :: FilePath + , configRunner :: FilePath + , configExtraCompilerOptions :: [String] + , configExtraOptions :: [String] + -- ^ Extra options passed to the programs being run. + } + deriving (Show) + +changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig +changeProgConfig f config = config { configPrograms = f $ configPrograms config } + +setBackend :: FilePath -> ProgConfig -> ProgConfig +setBackend backend config = + config { configBackend = backend } + +setFuthark :: FilePath -> ProgConfig -> ProgConfig +setFuthark futhark config = + config { configFuthark = futhark } + +setRunner :: FilePath -> ProgConfig -> ProgConfig +setRunner runner config = + config { configRunner = runner } + +addCompilerOption :: String -> ProgConfig -> ProgConfig +addCompilerOption option config = + config { configExtraCompilerOptions = configExtraCompilerOptions config ++ [option] } + +addOption :: String -> ProgConfig -> ProgConfig +addOption option config = + config { configExtraOptions = configExtraOptions config ++ [option] } + +data TestMode = TypeCheck + | Compile + | Compiled + | Interpreted + | Everything + deriving (Eq, Show) + +commandLineOptions :: [FunOptDescr TestConfig] +commandLineOptions = [ + Option "t" ["typecheck"] + (NoArg $ Right $ \config -> config { configTestMode = TypeCheck }) + "Only perform type-checking" + , Option "i" ["interpreted"] + (NoArg $ Right $ \config -> config { configTestMode = Interpreted }) + "Only interpret" + , Option "c" ["compiled"] + (NoArg $ Right $ \config -> config { configTestMode = Compiled }) + "Only run compiled code" + , Option "C" ["compile"] + (NoArg $ Right $ \config -> config { configTestMode = Compile }) + "Only compile, do not run." + , Option [] ["no-terminal", "notty"] + (NoArg $ Right $ \config -> config { configLineOutput = True }) + "Provide simpler line-based output." + , Option [] ["backend"] + (ReqArg (Right . changeProgConfig . setBackend) "BACKEND") + "Backend used for compilation (defaults to 'c')." + , Option [] ["futhark"] + (ReqArg (Right . changeProgConfig . setFuthark) "PROGRAM") + "Program to run for subcommands (defaults to 'futhark')." + , Option [] ["runner"] + (ReqArg (Right . changeProgConfig . setRunner) "PROGRAM") + "The program used to run the Futhark-generated programs (defaults to nothing)." + , Option [] ["exclude"] + (ReqArg (\tag -> + Right $ \config -> + config { configExclude = T.pack tag : configExclude config }) + "TAG") + "Exclude test programs that define this tag." + , Option "p" ["pass-option"] + (ReqArg (Right . changeProgConfig . addOption) "OPT") + "Pass this option to programs being run." + , Option [] ["pass-compiler-option"] + (ReqArg (Right . changeProgConfig . addCompilerOption) "OPT") + "Pass this option to the compiler (or typechecker if in -t mode)." + ] + +main :: String -> [String] -> IO () +main = mainWithOptions defaultConfig commandLineOptions "options... programs..." $ \progs config -> + Just $ runTests config progs diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/CCUDA.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +module Futhark.CodeGen.Backends.CCUDA + ( compileProg + , GC.CParts(..) + , GC.asLibrary + , GC.asExecutable + ) where + +import qualified Language.C.Quote.OpenCL as C +import Data.List + +import qualified Futhark.CodeGen.Backends.GenericC as GC +import qualified Futhark.CodeGen.ImpGen.CUDA as ImpGen +import Futhark.Error +import Futhark.Representation.ExplicitMemory hiding (GetSize, CmpSizeLe, GetSizeMax) +import Futhark.MonadFreshNames +import Futhark.CodeGen.ImpCode.OpenCL +import Futhark.CodeGen.Backends.CCUDA.Boilerplate +import Futhark.CodeGen.Backends.GenericC.Options + +import Data.Maybe (catMaybes) + +compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError GC.CParts) +compileProg prog = do + res <- ImpGen.compileProg prog + case res of + Left err -> return $ Left err + Right (Program cuda_code cuda_prelude kernel_names _ sizes prog') -> + let extra = generateBoilerplate cuda_code cuda_prelude + kernel_names sizes + in Right <$> GC.compileProg operations extra cuda_includes + [Space "device", Space "local", DefaultSpace] cliOptions prog' + where + operations :: GC.Operations OpenCL () + operations = GC.Operations + { GC.opsWriteScalar = writeCUDAScalar + , GC.opsReadScalar = readCUDAScalar + , GC.opsAllocate = allocateCUDABuffer + , GC.opsDeallocate = deallocateCUDABuffer + , GC.opsCopy = copyCUDAMemory + , GC.opsStaticArray = staticCUDAArray + , GC.opsMemoryType = cudaMemoryType + , GC.opsCompiler = callKernel + , GC.opsFatMemory = True + } + cuda_includes = unlines [ "#include " + , "#include " + ] + +cliOptions :: [Option] +cliOptions = [ Option { optionLongName = "dump-cuda" + , optionShortName = Nothing + , optionArgument = RequiredArgument + , optionAction = [C.cstm|futhark_context_config_dump_program_to(cfg, optarg);|] + } + , Option { optionLongName = "load-cuda" + , optionShortName = Nothing + , optionArgument = RequiredArgument + , optionAction = [C.cstm|futhark_context_config_load_program_from(cfg, optarg);|] + } + , Option { optionLongName = "dump-ptx" + , optionShortName = Nothing + , optionArgument = RequiredArgument + , optionAction = [C.cstm|futhark_context_config_dump_ptx_to(cfg, optarg);|] + } + , Option { optionLongName = "load-ptx" + , optionShortName = Nothing + , optionArgument = RequiredArgument + , optionAction = [C.cstm|futhark_context_config_load_ptx_from(cfg, optarg);|] + } + , Option { optionLongName = "print-sizes" + , optionShortName = Nothing + , optionArgument = NoArgument + , optionAction = [C.cstm|{ + int n = futhark_get_num_sizes(); + for (int i = 0; i < n; i++) { + printf("%s (%s)\n", futhark_get_size_name(i), + futhark_get_size_class(i)); + } + exit(0); + }|] + } + ] + +writeCUDAScalar :: GC.WriteScalar OpenCL () +writeCUDAScalar mem idx t "device" _ val = do + val' <- newVName "write_tmp" + GC.stm [C.cstm|{$ty:t $id:val' = $exp:val; + CUDA_SUCCEED( + cuMemcpyHtoD($exp:mem + $exp:idx, + &$id:val', + sizeof($ty:t))); + }|] +writeCUDAScalar _ _ _ space _ _ = + fail $ "Cannot write to '" ++ space ++ "' memory space." + +readCUDAScalar :: GC.ReadScalar OpenCL () +readCUDAScalar mem idx t "device" _ = do + val <- newVName "read_res" + GC.decl [C.cdecl|$ty:t $id:val;|] + GC.stm [C.cstm|CUDA_SUCCEED( + cuMemcpyDtoH(&$id:val, + $exp:mem + $exp:idx, + sizeof($ty:t))); + |] + return [C.cexp|$id:val|] +readCUDAScalar _ _ _ space _ = + fail $ "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 _ _ _ "local" = return () +allocateCUDABuffer _ _ _ space = + fail $ "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 _ _ "local" = return () +deallocateCUDABuffer _ _ space = + fail $ "Cannot deallocate in '" ++ space ++ "' memory space." + +copyCUDAMemory :: GC.Copy OpenCL () +copyCUDAMemory dstmem dstidx dstSpace srcmem srcidx srcSpace nbytes = do + fn <- memcpyFun dstSpace srcSpace + GC.stm [C.cstm|CUDA_SUCCEED( + $id:fn($exp:dstmem + $exp:dstidx, + $exp:srcmem + $exp:srcidx, + $exp:nbytes)); + |] + where + 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 + ++ "' from '" ++ show srcSpace ++ "'." + +staticCUDAArray :: GC.StaticArray OpenCL () +staticCUDAArray name "device" t vals = do + let ct = GC.primTypeToCType t + vals' = [[C.cinit|$exp:v|] | v <- map GC.compilePrimValue vals] + num_elems = length vals + name_realtype <- newVName $ baseString name ++ "_realtype" + GC.libDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:num_elems] = {$inits:vals'};|] + -- Fake a memory block. + GC.contextField (pretty name) [C.cty|struct memblock_device|] Nothing + -- During startup, copy the data to where we need it. + GC.atInit [C.cstm|{ + ctx->$id:name.references = NULL; + ctx->$id:name.size = 0; + CUDA_SUCCEED(cuMemAlloc(&ctx->$id:name.mem, + ($int:num_elems > 0 ? $int:num_elems : 1)*sizeof($ty:ct))); + if ($int:num_elems > 0) { + CUDA_SUCCEED(cuMemcpyHtoD(ctx->$id:name.mem, $id:name_realtype, + $int:num_elems*sizeof($ty:ct))); + } + }|] + GC.item [C.citem|struct memblock_device $id:name = ctx->$id:name;|] +staticCUDAArray _ space _ _ = + fail $ "CUDA backend cannot create static array in '" ++ space + ++ "' memory space" + +cudaMemoryType :: GC.MemoryType OpenCL () +cudaMemoryType "device" = return [C.cty|typename CUdeviceptr|] +cudaMemoryType "local" = pure [C.cty|unsigned char|] -- dummy type +cudaMemoryType space = + fail $ "CUDA backend does not support '" ++ space ++ "' memory space." + +callKernel :: GC.OpCompiler OpenCL () +callKernel (HostCode c) = GC.compileCode c +callKernel (GetSize v key) = + GC.stm [C.cstm|$id:v = ctx->sizes.$id:key;|] +callKernel (CmpSizeLe v key x) = do + x' <- GC.compileExp x + GC.stm [C.cstm|$id:v = ctx->sizes.$id:key <= $exp:x';|] +callKernel (GetSizeMax v size_class) = + let field = "max_" ++ cudaSizeClass size_class + in GC.stm [C.cstm|$id:v = ctx->cuda.$id:field;|] + where + cudaSizeClass (SizeThreshold _) = "threshold" + cudaSizeClass SizeGroup = "block_size" + cudaSizeClass SizeNumGroups = "grid_size" + cudaSizeClass SizeTile = "tile_size" +callKernel (LaunchKernel name args num_blocks block_size) = do + args_arr <- newVName "kernel_args" + time_start <- newVName "time_start" + time_end <- newVName "time_end" + (args', shared_vars) <- unzip <$> mapM mkArgs args + let (shared_sizes, shared_offsets) = unzip $ catMaybes shared_vars + shared_offsets_sc = mkOffsets shared_sizes + shared_args = zip shared_offsets shared_offsets_sc + shared_tot = last shared_offsets_sc + mapM_ (\(arg,offset) -> + GC.decl [C.cdecl|unsigned int $id:arg = $exp:offset;|] + ) shared_args + + (grid_x, grid_y, grid_z) <- mkDims <$> mapM GC.compileExp num_blocks + (block_x, block_y, block_z) <- mkDims <$> mapM GC.compileExp block_size + let perm_args + | length num_blocks == 3 = [ [C.cinit|&perm[0]|], [C.cinit|&perm[1]|], [C.cinit|&perm[2]|] ] + | otherwise = [] + let args'' = perm_args ++ [ [C.cinit|&$id:a|] | a <- args' ] + sizes_nonzero = expsNotZero [grid_x, grid_y, grid_z, + block_x, block_y, block_z] + GC.stm [C.cstm| + if ($exp:sizes_nonzero) { + int perm[3] = { 0, 1, 2 }; + + if ($exp:grid_y > (1<<16)) { + perm[1] = perm[0]; + perm[0] = 1; + } + + if ($exp:grid_z > (1<<16)) { + perm[2] = perm[0]; + perm[0] = 2; + } + + size_t grid[3]; + grid[perm[0]] = $exp:grid_x; + grid[perm[1]] = $exp:grid_y; + grid[perm[2]] = $exp:grid_z; + + void *$id:args_arr[] = { $inits:args'' }; + typename int64_t $id:time_start = 0, $id:time_end = 0; + if (ctx->debugging) { + fprintf(stderr, "Launching %s with grid size (", $string:name); + $stms:(printSizes [grid_x, grid_y, grid_z]) + fprintf(stderr, ") and block size ("); + $stms:(printSizes [block_x, block_y, block_z]) + fprintf(stderr, ").\n"); + $id:time_start = get_wall_time(); + } + CUDA_SUCCEED( + cuLaunchKernel(ctx->$id:name, + grid[0], grid[1], grid[2], + $exp:block_x, $exp:block_y, $exp:block_z, + $exp:shared_tot, NULL, + $id:args_arr, NULL)); + if (ctx->debugging) { + CUDA_SUCCEED(cuCtxSynchronize()); + $id:time_end = get_wall_time(); + fprintf(stderr, "Kernel %s runtime: %ldus\n", + $string:name, $id:time_end - $id:time_start); + } + }|] + where + mkDims [] = ([C.cexp|0|] , [C.cexp|0|], [C.cexp|0|]) + mkDims [x] = (x, [C.cexp|1|], [C.cexp|1|]) + mkDims [x,y] = (x, y, [C.cexp|1|]) + mkDims (x:y:z:_) = (x, y, z) + addExp x y = [C.cexp|$exp:x + $exp:y|] + alignExp e = [C.cexp|$exp:e + ((8 - ($exp:e % 8)) % 8)|] + mkOffsets = scanl (\a b -> a `addExp` alignExp b) [C.cexp|0|] + expNotZero e = [C.cexp|$exp:e != 0|] + expAnd a b = [C.cexp|$exp:a && $exp:b|] + expsNotZero = foldl expAnd [C.cexp|1|] . map expNotZero + mkArgs (ValueKArg e t) = + (,Nothing) <$> GC.compileExpToName "kernel_arg" t e + mkArgs (MemKArg v) = do + v' <- GC.rawMem v + arg <- newVName "kernel_arg" + GC.decl [C.cdecl|typename CUdeviceptr $id:arg = $exp:v';|] + return (arg, Nothing) + mkArgs (SharedMemoryKArg (Count c)) = do + num_bytes <- GC.compileExp c + size <- newVName "shared_size" + offset <- newVName "shared_offset" + GC.decl [C.cdecl|unsigned int $id:size = $exp:num_bytes;|] + return (offset, Just (size, offset)) + + printSizes = + intercalate [[C.cstm|fprintf(stderr, ", ");|]] . map printSize + printSize e = + [[C.cstm|fprintf(stderr, "%zu", $exp:e);|]] diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Futhark.CodeGen.Backends.CCUDA.Boilerplate + ( + generateBoilerplate + ) where + +import qualified Language.C.Quote.OpenCL as C + +import qualified Futhark.CodeGen.Backends.GenericC as GC +import Futhark.Representation.ExplicitMemory hiding (GetSize, CmpSizeLe, GetSizeMax) +import Futhark.CodeGen.ImpCode.OpenCL +import Futhark.Util (chunk, zEncodeString) + +import qualified Data.Map as M +import Data.FileEmbed (embedStringFile) + + + +generateBoilerplate :: String -> String -> [String] + -> M.Map Name SizeClass + -> GC.CompilerM OpenCL () () +generateBoilerplate cuda_program cuda_prelude kernel_names sizes = do + GC.earlyDecls [C.cunit| + $esc:("#include ") + $esc:("#include ") + $esc:("typedef CUdeviceptr fl_mem_t;") + $esc:free_list_h + $esc:cuda_h + const char *cuda_program[] = {$inits:fragments, NULL}; + |] + + generateSizeFuns sizes + cfg <- generateConfigFuns sizes + generateContextFuns cfg kernel_names sizes + where + cuda_h = $(embedStringFile "rts/c/cuda.h") + free_list_h = $(embedStringFile "rts/c/free_list.h") + fragments = map (\s -> [C.cinit|$string:s|]) + $ chunk 2000 (cuda_prelude ++ cuda_program) + +generateSizeFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () () +generateSizeFuns sizes = do + let size_name_inits = map (\k -> [C.cinit|$string:(pretty k)|]) $ M.keys sizes + size_var_inits = map (\k -> [C.cinit|$string:(zEncodeString (pretty k))|]) $ M.keys sizes + size_class_inits = map (\c -> [C.cinit|$string:(pretty c)|]) $ M.elems sizes + num_sizes = M.size sizes + + GC.libDecl [C.cedecl|static const char *size_names[] = { $inits:size_name_inits };|] + GC.libDecl [C.cedecl|static const char *size_vars[] = { $inits:size_var_inits };|] + GC.libDecl [C.cedecl|static const char *size_classes[] = { $inits:size_class_inits };|] + + GC.publicDef_ "get_num_sizes" GC.InitDecl $ \s -> + ([C.cedecl|int $id:s(void);|], + [C.cedecl|int $id:s(void) { + return $int:num_sizes; + }|]) + + GC.publicDef_ "get_size_name" GC.InitDecl $ \s -> + ([C.cedecl|const char* $id:s(int);|], + [C.cedecl|const char* $id:s(int i) { + return size_names[i]; + }|]) + + GC.publicDef_ "get_size_class" GC.InitDecl $ \s -> + ([C.cedecl|const char* $id:s(int);|], + [C.cedecl|const char* $id:s(int i) { + return size_classes[i]; + }|]) + +generateConfigFuns :: M.Map Name SizeClass -> GC.CompilerM OpenCL () String +generateConfigFuns sizes = do + let size_decls = map (\k -> [C.csdecl|size_t $id:k;|]) $ M.keys sizes + num_sizes = M.size sizes + GC.libDecl [C.cedecl|struct sizes { $sdecls:size_decls };|] + cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> + ([C.cedecl|struct $id:s;|], + [C.cedecl|struct $id:s { struct cuda_config cu_cfg; + size_t sizes[$int:num_sizes]; + };|]) + + let size_value_inits = map (\i -> [C.cstm|cfg->sizes[$int:i] = 0;|]) + [0..M.size sizes-1] + GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> + ([C.cedecl|struct $id:cfg* $id:s(void);|], + [C.cedecl|struct $id:cfg* $id:s(void) { + struct $id:cfg *cfg = malloc(sizeof(struct $id:cfg)); + if (cfg == NULL) { + return NULL; + } + + $stms:size_value_inits + cuda_config_init(&cfg->cu_cfg, $int:num_sizes, + size_names, size_vars, + cfg->sizes, size_classes); + return cfg; + }|]) + + GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg) { + free(cfg); + }|]) + + GC.publicDef_ "context_config_set_debugging" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { + cfg->cu_cfg.logging = cfg->cu_cfg.debugging = flag; + }|]) + + GC.publicDef_ "context_config_set_logging" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) { + cfg->cu_cfg.logging = flag; + }|]) + + GC.publicDef_ "context_config_set_device" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *s) { + set_preferred_device(&cfg->cu_cfg, s); + }|]) + + GC.publicDef_ "context_config_dump_program_to" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { + cfg->cu_cfg.dump_program_to = path; + }|]) + + GC.publicDef_ "context_config_load_program_from" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { + cfg->cu_cfg.load_program_from = path; + }|]) + + GC.publicDef_ "context_config_dump_ptx_to" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { + cfg->cu_cfg.dump_ptx_to = path; + }|]) + + GC.publicDef_ "context_config_load_ptx_from" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { + cfg->cu_cfg.load_ptx_from = path; + }|]) + + GC.publicDef_ "context_config_set_default_block_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 -> + ([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; + }|]) + + GC.publicDef_ "context_config_set_default_tile_size" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { + cfg->cu_cfg.default_tile_size = size; + cfg->cu_cfg.default_tile_size_changed = 1; + }|]) + + GC.publicDef_ "context_config_set_default_threshold" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, int num);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, int size) { + cfg->cu_cfg.default_threshold = size; + }|]) + + GC.publicDef_ "context_config_set_size" GC.InitDecl $ \s -> + ([C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value);|], + [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value) { + + for (int i = 0; i < $int:num_sizes; i++) { + if (strcmp(size_name, size_names[i]) == 0) { + cfg->sizes[i] = size_value; + return 0; + } + } + return 1; + }|]) + return cfg + +generateContextFuns :: String -> [String] + -> M.Map Name SizeClass + -> GC.CompilerM OpenCL () () +generateContextFuns cfg kernel_names sizes = do + final_inits <- GC.contextFinalInits + (fields, init_fields) <- GC.contextContents + let kernel_fields = map (\k -> [C.csdecl|typename CUfunction $id:k;|]) + kernel_names + + ctx <- GC.publicDef "context" GC.InitDecl $ \s -> + ([C.cedecl|struct $id:s;|], + [C.cedecl|struct $id:s { + int detail_memory; + int debugging; + typename lock_t lock; + char *error; + $sdecls:fields + $sdecls:kernel_fields + struct cuda_context cuda; + struct sizes sizes; + };|]) + + let set_sizes = zipWith (\i k -> [C.cstm|ctx->sizes.$id:k = cfg->sizes[$int:i];|]) + [(0::Int)..] $ M.keys sizes + + GC.publicDef_ "context_new" GC.InitDecl $ \s -> + ([C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], + [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) { + struct $id:ctx* ctx = malloc(sizeof(struct $id:ctx)); + if (ctx == NULL) { + return NULL; + } + ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging; + + ctx->cuda.cfg = cfg->cu_cfg; + create_lock(&ctx->lock); + $stms:init_fields + + cuda_setup(&ctx->cuda, cuda_program); + $stms:(map (loadKernelByName) kernel_names) + + $stms:final_inits + $stms:set_sizes + return ctx; + }|]) + + GC.publicDef_ "context_free" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:ctx* ctx);|], + [C.cedecl|void $id:s(struct $id:ctx* ctx) { + cuda_cleanup(&ctx->cuda); + free_lock(&ctx->lock); + free(ctx); + }|]) + + GC.publicDef_ "context_sync" GC.InitDecl $ \s -> + ([C.cedecl|int $id:s(struct $id:ctx* ctx);|], + [C.cedecl|int $id:s(struct $id:ctx* ctx) { + CUDA_SUCCEED(cuCtxSynchronize()); + return 0; + }|]) + + GC.publicDef_ "context_get_error" GC.InitDecl $ \s -> + ([C.cedecl|char* $id:s(struct $id:ctx* ctx);|], + [C.cedecl|char* $id:s(struct $id:ctx* ctx) { + return ctx->error; + }|]) + where + loadKernelByName name = + [C.cstm|CUDA_SUCCEED(cuModuleGetFunction(&ctx->$id:name, + ctx->cuda.module, $string:name));|] 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 @@ -91,16 +91,24 @@ , optionArgument = RequiredArgument , optionAction = [C.cstm|futhark_context_config_load_program_from(cfg, optarg);|] } + , Option { optionLongName = "dump-opencl-binary" + , optionShortName = Nothing + , optionArgument = RequiredArgument + , optionAction = [C.cstm|futhark_context_config_dump_binary_to(cfg, optarg);|] + } + , Option { optionLongName = "load-opencl-binary" + , optionShortName = Nothing + , optionArgument = RequiredArgument + , optionAction = [C.cstm|futhark_context_config_load_binary_from(cfg, optarg);|] + } , Option { optionLongName = "print-sizes" , optionShortName = Nothing , optionArgument = NoArgument , optionAction = [C.cstm|{ int n = futhark_get_num_sizes(); for (int i = 0; i < n; i++) { - if (strcmp(futhark_get_size_entry(i), entry_point) == 0) { - printf("%s (%s)\n", futhark_get_size_name(i), - futhark_get_size_class(i)); - } + printf("%s (%s)\n", futhark_get_size_name(i), + futhark_get_size_class(i)); } exit(0); }|] @@ -276,11 +284,11 @@ callKernel (HostCode c) = GC.compileCode c -callKernel (LaunchKernel name args kernel_size workgroup_size) = do +callKernel (LaunchKernel name args num_workgroups workgroup_size) = do zipWithM_ setKernelArg [(0::Int)..] args - kernel_size' <- mapM GC.compileExp kernel_size + num_workgroups' <- mapM GC.compileExp num_workgroups workgroup_size' <- mapM GC.compileExp workgroup_size - launchKernel name kernel_size' workgroup_size' + launchKernel name num_workgroups' workgroup_size' where setKernelArg i (ValueKArg e bt) = do v <- GC.compileExpToName "kernel_arg" bt e GC.stm [C.cstm| @@ -301,7 +309,7 @@ launchKernel :: C.ToExp a => String -> [a] -> [a] -> GC.CompilerM op s () -launchKernel kernel_name kernel_dims workgroup_dims = do +launchKernel kernel_name num_workgroups workgroup_dims = do global_work_size <- newVName "global_work_size" time_start <- newVName "time_start" time_end <- newVName "time_end" @@ -336,6 +344,7 @@ } }|] where kernel_rank = length kernel_dims + kernel_dims = zipWith multExp num_workgroups workgroup_dims kernel_dims' = map toInit kernel_dims workgroup_dims' = map toInit workgroup_dims total_elements = foldl multExp [C.cexp|1|] kernel_dims diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -15,10 +15,10 @@ import Futhark.CodeGen.ImpCode.OpenCL import qualified Futhark.CodeGen.Backends.GenericC as GC import Futhark.CodeGen.OpenCL.Kernels -import Futhark.Util (chunk) +import Futhark.Util (chunk, zEncodeString) generateBoilerplate :: String -> String -> [String] -> [PrimType] - -> M.Map VName (SizeClass, Name) + -> M.Map Name SizeClass -> GC.CompilerM OpenCL () () generateBoilerplate opencl_code opencl_prelude kernel_names types sizes = do final_inits <- GC.contextFinalInits @@ -29,13 +29,13 @@ GC.earlyDecls top_decls let size_name_inits = map (\k -> [C.cinit|$string:(pretty k)|]) $ M.keys sizes - size_class_inits = map (\(c,_) -> [C.cinit|$string:(pretty c)|]) $ M.elems sizes - size_entry_points_inits = map (\(_,e) -> [C.cinit|$string:(pretty e)|]) $ M.elems sizes + size_var_inits = map (\k -> [C.cinit|$string:(zEncodeString (pretty k))|]) $ M.keys sizes + size_class_inits = map (\c -> [C.cinit|$string:(pretty c)|]) $ M.elems sizes num_sizes = M.size sizes GC.libDecl [C.cedecl|static const char *size_names[] = { $inits:size_name_inits };|] + GC.libDecl [C.cedecl|static const char *size_vars[] = { $inits:size_var_inits };|] GC.libDecl [C.cedecl|static const char *size_classes[] = { $inits:size_class_inits };|] - GC.libDecl [C.cedecl|static const char *size_entry_points[] = { $inits:size_entry_points_inits };|] GC.publicDef_ "get_num_sizes" GC.InitDecl $ \s -> ([C.cedecl|int $id:s(void);|], @@ -55,12 +55,6 @@ return size_classes[i]; }|]) - GC.publicDef_ "get_size_entry" GC.InitDecl $ \s -> - ([C.cedecl|const char* $id:s(int);|], - [C.cedecl|const char* $id:s(int i) { - return size_entry_points[i]; - }|]) - let size_decls = map (\k -> [C.csdecl|size_t $id:k;|]) $ M.keys sizes GC.libDecl [C.cedecl|struct sizes { $sdecls:size_decls };|] cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> @@ -80,7 +74,8 @@ $stms:size_value_inits opencl_config_init(&cfg->opencl, $int:num_sizes, - size_names, cfg->sizes, size_classes, size_entry_points); + size_names, size_vars, + cfg->sizes, size_classes); return cfg; }|]) @@ -126,6 +121,19 @@ cfg->opencl.load_program_from = path; }|]) + + GC.publicDef_ "context_config_dump_binary_to" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { + cfg->opencl.dump_binary_to = path; + }|]) + + GC.publicDef_ "context_config_load_binary_from" GC.InitDecl $ \s -> + ([C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path);|], + [C.cedecl|void $id:s(struct $id:cfg* cfg, const char *path) { + cfg->opencl.load_binary_from = path; + }|]) + 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) { @@ -317,17 +325,28 @@ $stms:(map sizeHeuristicsCode sizeHeuristicsTable) }|]] + free_list_h = $(embedStringFile "rts/c/free_list.h") openCL_h = $(embedStringFile "rts/c/opencl.h") program_fragments = opencl_program_fragments ++ [[C.cinit|NULL|]] openCL_boilerplate = [C.cunit| + + $esc:("#define CL_USE_DEPRECATED_OPENCL_1_2_APIS") + $esc:("#define CL_SILENCE_DEPRECATION // For macOS.") + $esc:("#ifdef __APPLE__") + $esc:(" #include ") + $esc:("#else") + $esc:(" #include ") + $esc:("#endif") + $esc:("typedef cl_mem fl_mem_t;") + $esc:free_list_h $esc:openCL_h const char *opencl_program[] = {$inits:program_fragments};|] loadKernelByName :: String -> C.Stm loadKernelByName name = [C.cstm|{ ctx->$id:name = clCreateKernel(prog, $string:name, &error); - assert(error == 0); + OPENCL_SUCCEED_FATAL(error); if (ctx->debugging) { fprintf(stderr, "Created kernel %s.\n", $string:name); } @@ -373,7 +392,7 @@ [C.cstm| if ($exp:which' == 0 && strstr(option->platform_name, $string:platform_name) != NULL && - option->device_type == $exp:(clDeviceType device_type)) { + (option->device_type & $exp:(clDeviceType device_type)) == $exp:(clDeviceType device_type)) { $stm:get_size }|] where clDeviceType DeviceGPU = [C.cexp|CL_DEVICE_TYPE_GPU|] 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 @@ -17,6 +17,7 @@ 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') @@ -119,24 +120,32 @@ callKernel :: CS.OpCompiler Imp.OpenCL () callKernel (Imp.GetSize v key) = CS.stm $ Reassign (Var (CS.compileName v)) $ - Field (Var "Ctx.Sizes") $ pretty key + Field (Var "Ctx.Sizes") $ zEncodeString $ pretty key callKernel (Imp.GetSizeMax v size_class) = CS.stm $ Reassign (Var (CS.compileName v)) $ - Var $ "max_" ++ pretty size_class + Field (Var "Ctx.OpenCL") $ + case size_class of Imp.SizeGroup -> "MaxGroupSize" + Imp.SizeNumGroups -> "MaxNumGroups" + Imp.SizeTile -> "MaxTileSize" + Imp.SizeThreshold{} -> "MaxThreshold" callKernel (Imp.HostCode c) = CS.compileCode c -callKernel (Imp.LaunchKernel name args kernel_size workgroup_size) = do - kernel_size' <- mapM CS.compileExp kernel_size - let total_elements = foldl mult_exp (Integer 1) kernel_size' - let cond = BinOp "!=" total_elements (Integer 0) +callKernel (Imp.LaunchKernel name args num_workgroups workgroup_size) = do + num_workgroups' <- mapM CS.compileExp num_workgroups workgroup_size' <- mapM CS.compileExp workgroup_size - body <- CS.collect $ launchKernel name kernel_size' workgroup_size' args + let kernel_size = zipWith mult_exp num_workgroups' workgroup_size' + total_elements = foldl mult_exp (Integer 1) kernel_size + cond = BinOp "!=" total_elements (Integer 0) + body <- CS.collect $ launchKernel name kernel_size workgroup_size' args CS.stm $ If cond body [] where mult_exp = BinOp "*" -callKernel _ = undefined +callKernel (Imp.CmpSizeLe v key x) = do + x' <- CS.compileExp x + CS.stm $ Reassign (Var (CS.compileName v)) $ + BinOp "<=" (Field (Var "Ctx.Sizes") (zEncodeString $ pretty key)) x' launchKernel :: String -> [CSExp] -> [CSExp] -> [Imp.KernelArg] -> CS.CompilerM op s () launchKernel kernel_name kernel_dims workgroup_dims args = do diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs @@ -11,7 +11,7 @@ import Futhark.CodeGen.Backends.GenericCSharp as CS import Futhark.CodeGen.Backends.GenericCSharp.AST as AST import Futhark.CodeGen.OpenCL.Kernels - +import Futhark.Util (zEncodeString) intT, longT, stringT, intArrayT, stringArrayT :: CSType intT = Primitive $ CSInt Int32T @@ -21,7 +21,7 @@ stringArrayT = Composite $ ArrayT stringT generateBoilerplate :: String -> String -> [String] -> [PrimType] - -> M.Map VName (SizeClass, Name) + -> M.Map Name SizeClass -> CS.CompilerM OpenCL () () generateBoilerplate opencl_code opencl_prelude kernel_names types sizes = do final_inits <- CS.contextFinalInits @@ -34,17 +34,16 @@ CS.stm $ AssignTyped stringArrayT (Var "SizeNames") (Just $ Collection "string[]" (map (String . pretty) $ M.keys sizes)) - CS.stm $ AssignTyped stringArrayT (Var "SizeClasses") - (Just $ Collection "string[]" (map (String . pretty . fst) $ M.elems sizes)) + CS.stm $ AssignTyped stringArrayT (Var "SizeVars") + (Just $ Collection "string[]" (map (String . zEncodeString . pretty) $ M.keys sizes)) - CS.stm $ AssignTyped stringArrayT (Var "SizeEntryPoints") - (Just $ Collection "string[]" (map (String . pretty . snd) $ M.elems sizes)) + CS.stm $ AssignTyped stringArrayT (Var "SizeClasses") + (Just $ Collection "string[]" (map (String . pretty) $ M.elems sizes)) let get_num_sizes = CS.publicName "GetNumSizes" let get_size_name = CS.publicName "GetSizeName" let get_size_class = CS.publicName "GetSizeClass" - let get_size_entry = CS.publicName "GetSizeEntry" CS.stm $ CS.privateFunDef get_num_sizes intT [] @@ -53,8 +52,6 @@ [ Return $ Index (Var "SizeNames") (IdxExp $ Var "i") ] CS.stm $ CS.privateFunDef get_size_class (Primitive StringT) [(intT, "i")] [ Return $ Index (Var "SizeClasses") (IdxExp $ Var "i") ] - CS.stm $ CS.privateFunDef get_size_entry (Primitive StringT) [(intT, "i")] - [ Return $ Index (Var "SizeEntryPoints") (IdxExp $ Var "i") ] let cfg = CS.publicName "ContextConfig" let new_cfg = CS.publicName "ContextConfigNew" @@ -69,7 +66,7 @@ let cfg_set_default_threshold = CS.publicName "ContextConfigSetDefaultThreshold" let cfg_set_size = CS.publicName "ContextConfigSetSize" - CS.stm $ StructDef "Sizes" (map (\k -> (intT, pretty k)) $ M.keys sizes) + CS.stm $ StructDef "Sizes" (map (\k -> (intT, zEncodeString $ pretty k)) $ M.keys sizes) CS.stm $ StructDef cfg [ (CustomT "OpenCLConfig", "OpenCL") , (intArrayT, "Sizes")] @@ -78,7 +75,7 @@ [ Assign tmp_cfg $ CS.simpleInitClass cfg [] , Reassign (Field tmp_cfg "Sizes") (Collection "int[]" (replicate (M.size sizes) (Integer 0))) , Exp $ CS.simpleCall "OpenCLConfigInit" [ Out $ Field tmp_cfg "OpenCL", (Integer . toInteger) $ M.size sizes - , Var "SizeNames", Field tmp_cfg "Sizes", Var "SizeClasses" ] + , Var "SizeNames", Var "SizeVars", Field tmp_cfg "Sizes", Var "SizeClasses" ] , Return tmp_cfg ] @@ -152,7 +149,7 @@ let set_required_types = [Reassign (Var "RequiredTypes") (AST.Bool True) | FloatType Float64 `elem` types] - set_sizes = zipWith (\i k -> Reassign (Field (Var "Ctx.Sizes") (pretty k)) + set_sizes = zipWith (\i k -> Reassign (Field (Var "Ctx.Sizes") (zEncodeString $ pretty k)) (Index (Var "Cfg.Sizes") (IdxExp $ (Integer . toInteger) i))) [(0::Int)..] $ M.keys sizes 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 @@ -77,7 +77,6 @@ import Data.Loc import Data.Maybe import Data.FileEmbed -import qualified Data.Semigroup as Sem import Text.Printf import qualified Language.C.Syntax as C @@ -228,13 +227,12 @@ accItems :: DL.DList C.BlockItem } -instance Sem.Semigroup (CompilerAcc op s) where +instance Semigroup (CompilerAcc op s) where CompilerAcc items1 <> CompilerAcc items2 = CompilerAcc (items1<>items2) instance Monoid (CompilerAcc op s) where mempty = CompilerAcc mempty - mappend = (Sem.<>) envOpCompiler :: CompilerEnv op s -> OpCompiler op s envOpCompiler = opsCompiler . envOperations @@ -348,6 +346,9 @@ item :: C.BlockItem -> CompilerM op s () item x = tell $ mempty { accItems = DL.singleton x } + +instance C.ToIdent Name where + toIdent = C.toIdent . zEncodeString . nameToString instance C.ToIdent VName where toIdent = C.toIdent . zEncodeString . pretty 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 @@ -1,1404 +1,1402 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, LambdaCase #-} -{-# LANGUAGE TupleSections #-} --- | A generic C# code generator which is polymorphic in the type --- of the operations. Concretely, we use this to handle both --- sequential and OpenCL C# code. -module Futhark.CodeGen.Backends.GenericCSharp - ( compileProg - , Constructor (..) - , emptyConstructor - - , assignScalarPointer - , toIntPtr - , compileName - , compileDim - , compileExp - , compileCode - , compilePrimValue - , compilePrimType - , compilePrimTypeExt - , compilePrimTypeToAST - , compilePrimTypeToASText - , contextFinalInits - , debugReport - - , Operations (..) - , defaultOperations - - , unpackDim - - , CompilerM (..) - , OpCompiler - , WriteScalar - , ReadScalar - , Allocate - , Copy - , StaticArray - , EntryOutput - , EntryInput - - , CompilerEnv(..) - , CompilerState(..) - , stm - , stms - , atInit - , staticMemDecl - , staticMemAlloc - , addMemberDecl - , beforeParse - , collect' - , collect - , simpleCall - , callMethod - , simpleInitClass - , parametrizedCall - - , copyMemoryDefaultSpace - , consoleErrorWrite - , consoleErrorWriteLine - , consoleWrite - , consoleWriteLine - - , publicName - , sizeOf - , privateFunDef - , publicFunDef - , getDefaultDecl - ) where - -import Control.Monad.Identity -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.RWS -import Control.Arrow((&&&)) -import Data.Maybe -import Data.List -import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem - -import Futhark.Representation.Primitive hiding (Bool) -import Futhark.MonadFreshNames -import Futhark.Representation.AST.Syntax (Space(..)) -import qualified Futhark.CodeGen.ImpCode as Imp -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) - --- | A substitute expression compiler, tried before the main --- compilation function. -type OpCompiler op s = op -> CompilerM op s () - --- | Write a scalar to the given memory block with the given index and --- in the given memory space. -type WriteScalar op s = VName -> CSExp -> PrimType -> Imp.SpaceId -> CSExp - -> CompilerM op s () - --- | Read a scalar from the given memory block with the given index and --- in the given memory space. -type ReadScalar op s = VName -> CSExp -> PrimType -> Imp.SpaceId - -> CompilerM op s CSExp - --- | Allocate a memory block of the given size in the given memory --- space, saving a reference in the given variable name. -type Allocate op s = VName -> CSExp -> Imp.SpaceId - -> CompilerM op s () - --- | Copy from one memory block to another. -type Copy op s = VName -> CSExp -> Imp.Space -> - VName -> CSExp -> Imp.Space -> - CSExp -> PrimType -> - CompilerM op s () - --- | Create a static array of values - initialised at load time. -type StaticArray op s = VName -> Imp.SpaceId -> PrimType -> [PrimValue] -> CompilerM op s () - --- | Construct the C# array being returned from an entry point. -type EntryOutput op s = VName -> Imp.SpaceId -> - PrimType -> Imp.Signedness -> - [Imp.DimSize] -> - CompilerM op s CSExp - --- | Unpack the array being passed to an entry point. -type EntryInput op s = VName -> Imp.MemSize -> Imp.SpaceId -> - PrimType -> Imp.Signedness -> - [Imp.DimSize] -> - CSExp -> - CompilerM op s () - -data Operations op s = Operations { opsWriteScalar :: WriteScalar op s - , opsReadScalar :: ReadScalar op s - , opsAllocate :: Allocate op s - , opsCopy :: Copy op s - , opsStaticArray :: StaticArray op s - , opsCompiler :: OpCompiler op s - , opsEntryOutput :: EntryOutput op s - , opsEntryInput :: EntryInput op s - , opsSyncRun :: CSStmt - } - --- | A set of operations that fail for every operation involving --- non-default memory spaces. Uses plain pointers and @malloc@ for --- memory management. -defaultOperations :: Operations op s -defaultOperations = Operations { opsWriteScalar = defWriteScalar - , opsReadScalar = defReadScalar - , opsAllocate = defAllocate - , opsCopy = defCopy - , opsStaticArray = defStaticArray - , opsCompiler = defCompiler - , opsEntryOutput = defEntryOutput - , opsEntryInput = defEntryInput - , opsSyncRun = defSyncRun - } - where defWriteScalar _ _ _ _ _ = - fail "Cannot write to non-default memory space because I am dumb" - defReadScalar _ _ _ _ = - fail "Cannot read from non-default memory space" - defAllocate _ _ _ = - fail "Cannot allocate in non-default memory space" - defCopy _ _ _ _ _ _ _ _ = - fail "Cannot copy to or from non-default memory space" - defStaticArray _ _ _ _ = - fail "Cannot create static array in non-default memory space" - defCompiler _ = - fail "The default compiler cannot compile extended operations" - defEntryOutput _ _ _ _ = - fail "Cannot return array not in default memory space" - defEntryInput _ _ _ _ = - fail "Cannot accept array not in default memory space" - defSyncRun = - Pass - -data CompilerEnv op s = CompilerEnv { - envOperations :: Operations op s - , envFtable :: M.Map Name [Imp.Type] -} - -data CompilerAcc op s = CompilerAcc { - accItems :: [CSStmt] - , accFreedMem :: [VName] - } - -instance Sem.Semigroup (CompilerAcc op s) where - CompilerAcc items1 freed1 <> CompilerAcc items2 freed2 = - CompilerAcc (items1<>items2) (freed1<>freed2) - -instance Monoid (CompilerAcc op s) where - mempty = CompilerAcc mempty mempty - mappend = (Sem.<>) - -envOpCompiler :: CompilerEnv op s -> OpCompiler op s -envOpCompiler = opsCompiler . envOperations - -envReadScalar :: CompilerEnv op s -> ReadScalar op s -envReadScalar = opsReadScalar . envOperations - -envWriteScalar :: CompilerEnv op s -> WriteScalar op s -envWriteScalar = opsWriteScalar . envOperations - -envAllocate :: CompilerEnv op s -> Allocate op s -envAllocate = opsAllocate . envOperations - -envCopy :: CompilerEnv op s -> Copy op s -envCopy = opsCopy . envOperations - -envStaticArray :: CompilerEnv op s -> StaticArray op s -envStaticArray = opsStaticArray . envOperations - -envEntryOutput :: CompilerEnv op s -> EntryOutput op s -envEntryOutput = opsEntryOutput . envOperations - -envEntryInput :: CompilerEnv op s -> EntryInput op s -envEntryInput = opsEntryInput . envOperations - -envSyncFun :: CompilerEnv op s -> CSStmt -envSyncFun = opsSyncRun . envOperations - -newCompilerEnv :: Imp.Functions op -> Operations op s -> CompilerEnv op s -newCompilerEnv (Imp.Functions funs) ops = - CompilerEnv { envOperations = ops - , envFtable = ftable <> builtinFtable - } - where ftable = M.fromList $ map funReturn funs - funReturn (name, Imp.Function _ outparams _ _ _ _) = (name, paramsTypes outparams) - builtinFtable = M.map (map Imp.Scalar . snd) builtInFunctions - -data CompilerState s = CompilerState { - compNameSrc :: VNameSource - , compBeforeParse :: [CSStmt] - , compInit :: [CSStmt] - , compStaticMemDecls :: [CSStmt] - , compStaticMemAllocs :: [CSStmt] - , compDebugItems :: [CSStmt] - , compUserState :: s - , compMemberDecls :: [CSStmt] - , compAssignedVars :: [VName] - , compDeclaredMem :: [(VName, Space)] -} - -newCompilerState :: VNameSource -> s -> CompilerState s -newCompilerState src s = CompilerState { compNameSrc = src - , compBeforeParse = [] - , compInit = [] - , compStaticMemDecls = [] - , compStaticMemAllocs = [] - , compDebugItems = [] - , compMemberDecls = [] - , compUserState = s - , compAssignedVars = [] - , compDeclaredMem = [] - } - -newtype CompilerM op s a = CompilerM (RWS (CompilerEnv op s) (CompilerAcc op s) (CompilerState s) a) - deriving (Functor, Applicative, Monad, - MonadState (CompilerState s), - MonadReader (CompilerEnv op s), - MonadWriter (CompilerAcc op s)) - -instance MonadFreshNames (CompilerM op s) where - getNameSource = gets compNameSrc - putNameSource src = modify $ \s -> s { compNameSrc = src } - -collect :: CompilerM op s () -> CompilerM op s [CSStmt] -collect m = pass $ do - ((), w) <- listen m - return (accItems w, - const w { accItems = mempty} ) - -collect' :: CompilerM op s a -> CompilerM op s (a, [CSStmt]) -collect' m = pass $ do - (x, w) <- listen m - return ((x, accItems w), - const w { accItems = mempty}) - -beforeParse :: CSStmt -> CompilerM op s () -beforeParse x = modify $ \s -> - s { compBeforeParse = compBeforeParse s ++ [x] } - -atInit :: CSStmt -> CompilerM op s () -atInit x = modify $ \s -> - s { compInit = compInit s ++ [x] } - -staticMemDecl :: CSStmt -> CompilerM op s () -staticMemDecl x = modify $ \s -> - s { compStaticMemDecls = compStaticMemDecls s ++ [x] } - -staticMemAlloc :: CSStmt -> CompilerM op s () -staticMemAlloc x = modify $ \s -> - s { compStaticMemAllocs = compStaticMemAllocs s ++ [x] } - -addMemberDecl :: CSStmt -> CompilerM op s () -addMemberDecl x = modify $ \s -> - s { compMemberDecls = compMemberDecls s ++ [x] } - -contextFinalInits :: CompilerM op s [CSStmt] -contextFinalInits = gets compInit - -item :: CSStmt -> CompilerM op s () -item x = tell $ mempty { accItems = [x] } - -stm :: CSStmt -> CompilerM op s () -stm = item - -stms :: [CSStmt] -> CompilerM op s () -stms = mapM_ stm - -debugReport :: CSStmt -> CompilerM op s () -debugReport x = modify $ \s -> - s { compDebugItems = compDebugItems s ++ [x] } - -getVarAssigned :: VName -> CompilerM op s Bool -getVarAssigned vname = - elem vname <$> gets compAssignedVars - -setVarAssigned :: VName -> CompilerM op s () -setVarAssigned vname = modify $ \s -> - s { compAssignedVars = vname : compAssignedVars s} - -futharkFun :: String -> String -futharkFun s = "futhark_" ++ zEncodeString s - -paramsTypes :: [Imp.Param] -> [Imp.Type] -paramsTypes = map paramType - -paramType :: Imp.Param -> Imp.Type -paramType (Imp.MemParam _ space) = Imp.Mem (Imp.ConstSize 0) space -paramType (Imp.ScalarParam _ t) = Imp.Scalar t - -compileOutput :: Imp.Param -> (CSExp, CSType) -compileOutput = nameFun &&& typeFun - where nameFun = Var . compileName . Imp.paramName - typeFun = compileType . paramType - -getDefaultDecl :: Imp.Param -> CSStmt -getDefaultDecl (Imp.MemParam v DefaultSpace) = - Assign (Var $ compileName v) $ simpleCall "allocateMem" [Integer 0] -getDefaultDecl (Imp.MemParam v _) = - AssignTyped (CustomT "OpenCLMemblock") (Var $ compileName v) (Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"]) -getDefaultDecl (Imp.ScalarParam v Cert) = - Assign (Var $ compileName v) $ Bool True -getDefaultDecl (Imp.ScalarParam v t) = - Assign (Var $ compileName v) $ simpleInitClass (compilePrimType t) [] - - -runCompilerM :: Imp.Functions op -> Operations op s - -> VNameSource - -> s - -> CompilerM op s a - -> a -runCompilerM prog ops src userstate (CompilerM m) = - fst $ evalRWS m (newCompilerEnv prog ops) (newCompilerState src userstate) - -standardOptions :: [Option] -standardOptions = [ - Option { optionLongName = "write-runtime-to" - , optionShortName = Just 't' - , optionArgument = RequiredArgument - , optionAction = - [ - If (BinOp "!=" (Var "RuntimeFile") Null) - [Exp $ simpleCall "RuntimeFile.Close" []] [] - , Reassign (Var "RuntimeFile") $ - simpleInitClass "FileStream" [Var "optarg", Var "FileMode.Create"] - , Reassign (Var "RuntimeFileWriter") $ - simpleInitClass "StreamWriter" [Var "RuntimeFile"] - ] - }, - Option { optionLongName = "runs" - , optionShortName = Just 'r' - , optionArgument = RequiredArgument - , optionAction = - [ Reassign (Var "NumRuns") $ simpleCall "Convert.ToInt32" [Var "optarg"] - , Reassign (Var "DoWarmupRun") $ Bool True - ] - }, - Option { optionLongName = "entry-point" - , optionShortName = Just 'e' - , optionArgument = RequiredArgument - , optionAction = - [ Reassign (Var "EntryPoint") $ Var "optarg" ] - } - ] - --- | The class generated by the code generator must have a --- constructor, although it can be vacuous. -data Constructor = Constructor [CSFunDefArg] [CSStmt] - --- | A constructor that takes no arguments and does nothing. -emptyConstructor :: Constructor -emptyConstructor = Constructor [(Composite $ ArrayT $ Primitive StringT, "args")] [] - -constructorToConstructorDef :: Constructor -> String -> [CSStmt] -> CSStmt -constructorToConstructorDef (Constructor params body) name at_init = - ConstructorDef $ ClassConstructor name params $ body <> at_init - - -compileProg :: MonadFreshNames m => - Maybe String - -> Constructor - -> [CSStmt] - -> [CSStmt] - -> Operations op s - -> s - -> CompilerM op s () - -> [CSStmt] - -> [Space] - -> [Option] - -> Imp.Functions op - -> m String -compileProg module_name constructor imports defines ops userstate boilerplate pre_timing _ options prog@(Imp.Functions funs) = do - src <- getNameSource - let prog' = runCompilerM prog ops src userstate compileProg' - let imports' = [ Using Nothing "System" - , Using Nothing "System.Diagnostics" - , Using Nothing "System.Collections" - , Using Nothing "System.Collections.Generic" - , Using Nothing "System.IO" - , Using Nothing "System.Linq" - , Using Nothing "System.Runtime.InteropServices" - , Using Nothing "static System.ValueTuple" - , Using Nothing "static System.Convert" - , Using Nothing "static System.Math" - , Using Nothing "System.Numerics" - , Using Nothing "Mono.Options" ] ++ imports - - return $ pretty (CSProg $ imports' ++ prog') - where compileProg' = do - definitions <- mapM compileFunc funs - opencl_boilerplate <- collect boilerplate - compBeforeParses <- gets compBeforeParse - compInits <- gets compInit - staticDecls <- gets compStaticMemDecls - staticAllocs <- gets compStaticMemAllocs - extraMemberDecls <- gets compMemberDecls - let member_decls' = member_decls ++ extraMemberDecls ++ staticDecls - let at_inits' = at_inits ++ compBeforeParses ++ parse_options ++ compInits ++ staticAllocs - - - case module_name of - Just name -> do - entry_points <- mapM (compileEntryFun pre_timing) $ filter (Imp.functionEntry . snd) funs - let constructor' = constructorToConstructorDef constructor name at_inits' - return [ Namespace name [ClassDef $ PublicClass name $ member_decls' ++ - constructor' : defines' ++ opencl_boilerplate ++ - map PrivateFunDef definitions ++ - map PublicFunDef entry_points ]] - - - Nothing -> do - let name = "FutharkInternal" - let constructor' = constructorToConstructorDef constructor name at_inits' - (entry_point_defs, entry_point_names, entry_points) <- - unzip3 <$> mapM (callEntryFun pre_timing) - (filter (Imp.functionEntry . snd) funs) - - debug_ending <- gets compDebugItems - return [Namespace name ((ClassDef $ - PublicClass name $ - member_decls' ++ - constructor' : defines' ++ - opencl_boilerplate ++ - map PrivateFunDef (definitions ++ entry_point_defs) ++ - [PublicFunDef $ Def "InternalEntry" VoidT [] $ selectEntryPoint entry_point_names entry_points ++ debug_ending - ] - ) : - [ClassDef $ PublicClass "Program" - [StaticFunDef $ Def "Main" VoidT [(string_arrayT,"args")] main_entry]]) - ] - - - - string_arrayT = Composite $ ArrayT $ Primitive StringT - main_entry :: [CSStmt] - main_entry = [ Assign (Var "internalInstance") (simpleInitClass "FutharkInternal" [Var "args"]) - , Exp $ simpleCall "internalInstance.InternalEntry" [] - ] - - member_decls = - [ AssignTyped (CustomT "FileStream") (Var "RuntimeFile") Nothing - , AssignTyped (CustomT "StreamWriter") (Var "RuntimeFileWriter") Nothing - , AssignTyped (Primitive BoolT) (Var "DoWarmupRun") Nothing - , AssignTyped (Primitive $ CSInt Int32T) (Var "NumRuns") Nothing - , AssignTyped (Primitive StringT) (Var "EntryPoint") Nothing - ] - - at_inits = [ Reassign (Var "DoWarmupRun") (Bool False) - , Reassign (Var "NumRuns") (Integer 1) - , Reassign (Var "EntryPoint") (String "main") - , Exp $ simpleCall "ValueReader" [] - ] - - defines' = [ Escape csScalar - , Escape csMemory - , Escape csPanic - , Escape csExceptions - , Escape csReader] ++ defines - - parse_options = - generateOptionParser (standardOptions ++ options) - - selectEntryPoint entry_point_names entry_points = - [ Assign (Var "EntryPoints") $ - Collection "Dictionary" $ zipWith Pair (map String entry_point_names) entry_points, - If (simpleCall "!EntryPoints.ContainsKey" [Var "EntryPoint"]) - [ Exp $ simpleCall "Console.Error.WriteLine" - [simpleCall "string.Format" - [ String "No entry point '{0}'. Select another with --entry point. Options are:\n{1}" - , Var "EntryPoint" - , simpleCall "string.Join" - [ String "\n" - , Field (Var "EntryPoints") "Keys" ]]] - , Exp $ simpleCall "Environment.Exit" [Integer 1]] - [ Assign (Var "entryPointFun") $ - Index (Var "EntryPoints") (IdxExp $ Var "EntryPoint") - , Exp $ simpleCall "entryPointFun.Invoke" []] - ] - - -compileFunc :: (Name, Imp.Function op) -> CompilerM op s CSFunDef -compileFunc (fname, Imp.Function _ outputs inputs body _ _) = do - body' <- blockScope $ compileCode body - let inputs' = map compileTypedInput inputs - let outputs' = map compileOutput outputs - let outputDecls = map getDefaultDecl outputs - let (ret, retType) = unzip outputs' - let retType' = tupleOrSingleT retType - let ret' = [Return $ tupleOrSingle ret] - - case outputs of - [] -> return $ Def (futharkFun . nameToString $ fname) VoidT inputs' (outputDecls++body') - _ -> return $ Def (futharkFun . nameToString $ fname) retType' inputs' (outputDecls++body'++ret') - - -compileTypedInput :: Imp.Param -> (CSType, String) -compileTypedInput input = (typeFun input, nameFun input) - where nameFun = compileName . Imp.paramName - typeFun = compileType . paramType - -tupleOrSingleEntryT :: [CSType] -> CSType -tupleOrSingleEntryT [e] = e -tupleOrSingleEntryT es = Composite $ SystemTupleT es - -tupleOrSingleEntry :: [CSExp] -> CSExp -tupleOrSingleEntry [e] = e -tupleOrSingleEntry es = CreateSystemTuple es - -tupleOrSingleT :: [CSType] -> CSType -tupleOrSingleT [e] = e -tupleOrSingleT es = Composite $ TupleT es - -tupleOrSingle :: [CSExp] -> CSExp -tupleOrSingle [e] = e -tupleOrSingle es = Tuple es - -assignScalarPointer :: CSExp -> CSExp -> CSStmt -assignScalarPointer e ptr = - AssignTyped (PointerT VoidT) ptr (Just $ Addr e) - --- | A 'Call' where the function is a variable and every argument is a --- simple 'Arg'. -simpleCall :: String -> [CSExp] -> CSExp -simpleCall fname = Call (Var fname) . map simpleArg - --- | A 'Call' where the function is a variable and every argument is a --- simple 'Arg'. -parametrizedCall :: String -> String -> [CSExp] -> CSExp -parametrizedCall fname primtype = Call (Var fname') . map simpleArg - where fname' = concat [fname, "<", primtype, ">"] - -simpleArg :: CSExp -> CSArg -simpleArg = Arg Nothing - --- | A CallMethod -callMethod :: CSExp -> String -> [CSExp] -> CSExp -callMethod object method = CallMethod object (Var method) . map simpleArg - -simpleInitClass :: String -> [CSExp] -> CSExp -simpleInitClass fname =CreateObject (Var fname) . map simpleArg - -compileName :: VName -> String -compileName = zEncodeString . pretty - -compileType :: Imp.Type -> CSType -compileType (Imp.Scalar p) = compilePrimTypeToAST p -compileType (Imp.Mem _ space) = rawMemCSType space - -compilePrimTypeToAST :: PrimType -> CSType -compilePrimTypeToAST (IntType Int8) = Primitive $ CSInt Int8T -compilePrimTypeToAST (IntType Int16) = Primitive $ CSInt Int16T -compilePrimTypeToAST (IntType Int32) = Primitive $ CSInt Int32T -compilePrimTypeToAST (IntType Int64) = Primitive $ CSInt Int64T -compilePrimTypeToAST (FloatType Float32) = Primitive $ CSFloat FloatT -compilePrimTypeToAST (FloatType Float64) = Primitive $ CSFloat DoubleT -compilePrimTypeToAST Imp.Bool = Primitive BoolT -compilePrimTypeToAST Imp.Cert = Primitive BoolT - -compilePrimTypeToASText :: PrimType -> Imp.Signedness -> CSType -compilePrimTypeToASText (IntType Int8) Imp.TypeUnsigned = Primitive $ CSUInt UInt8T -compilePrimTypeToASText (IntType Int16) Imp.TypeUnsigned = Primitive $ CSUInt UInt16T -compilePrimTypeToASText (IntType Int32) Imp.TypeUnsigned = Primitive $ CSUInt UInt32T -compilePrimTypeToASText (IntType Int64) Imp.TypeUnsigned = Primitive $ CSUInt UInt64T -compilePrimTypeToASText (IntType Int8) _ = Primitive $ CSInt Int8T -compilePrimTypeToASText (IntType Int16) _ = Primitive $ CSInt Int16T -compilePrimTypeToASText (IntType Int32) _ = Primitive $ CSInt Int32T -compilePrimTypeToASText (IntType Int64) _ = Primitive $ CSInt Int64T -compilePrimTypeToASText (FloatType Float32) _ = Primitive $ CSFloat FloatT -compilePrimTypeToASText (FloatType Float64) _ = Primitive $ CSFloat DoubleT -compilePrimTypeToASText Imp.Bool _ = Primitive BoolT -compilePrimTypeToASText Imp.Cert _ = Primitive BoolT - -compileDim :: Imp.DimSize -> CSExp -compileDim (Imp.ConstSize i) = Integer $ toInteger i -compileDim (Imp.VarSize v) = Var $ compileName v - -unpackDim :: CSExp -> Imp.DimSize -> Int32 -> CompilerM op s () -unpackDim arr_name (Imp.ConstSize c) i = do - let shape_name = Field arr_name "Item2" -- array tuples are currently (data array * dimension array) currently - let constant_c = Integer $ toInteger c - let constant_i = Integer $ toInteger i - stm $ Assert (BinOp "==" constant_c (Index shape_name $ IdxExp constant_i)) [String "constant dimension wrong"] - -unpackDim arr_name (Imp.VarSize var) i = do - let shape_name = Field arr_name "Item2" - let src = Index shape_name $ IdxExp $ Integer $ toInteger i - let dest = Var $ compileName var - isAssigned <- getVarAssigned var - if isAssigned - then - stm $ Reassign dest $ Cast (Primitive $ CSInt Int32T) src - else do - stm $ Assign dest $ Cast (Primitive $ CSInt Int32T) src - setVarAssigned var - -entryPointOutput :: Imp.ExternalValue -> CompilerM op s CSExp -entryPointOutput (Imp.OpaqueValue _ vs) = - CreateSystemTuple <$> mapM (entryPointOutput . Imp.TransparentValue) vs - -entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) = - return $ cast $ Var $ compileName name - where cast = compileTypecastExt bt ept - -entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ Imp.DefaultSpace bt ept dims)) = do - let src = Var $ compileName mem - let createTuple = "createTuple_" ++ compilePrimTypeExt bt ept - return $ simpleCall createTuple [src, CreateArray (Primitive $ CSInt Int64T) $ map compileDim dims] - -entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ (Imp.Space sid) bt ept dims)) = do - unRefMem mem (Imp.Space sid) - pack_output <- asks envEntryOutput - pack_output mem sid bt ept dims - -entryPointInput :: (Int, Imp.ExternalValue, CSExp) -> CompilerM op s () -entryPointInput (i, Imp.OpaqueValue _ vs, e) = - mapM_ entryPointInput $ zip3 (repeat i) (map Imp.TransparentValue vs) $ - map (\idx -> Field e $ "Item" ++ show (idx :: Int)) [1..] - -entryPointInput (_, Imp.TransparentValue (Imp.ScalarValue bt _ name), e) = do - let vname' = Var $ compileName name - cast = compileTypecast bt - stm $ Assign vname' (cast e) - -entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem memsize Imp.DefaultSpace bt _ dims), e) = do - zipWithM_ (unpackDim e) dims [0..] - let arrayData = Field e "Item1" - let dest = Var $ compileName mem - unwrap_call = simpleCall "unwrapArray" [arrayData, sizeOf $ compilePrimTypeToAST bt] - case memsize of - Imp.VarSize sizevar -> - stm $ Assign (Var $ compileName sizevar) $ Field e "Item2.Length" - Imp.ConstSize _ -> - return () - stm $ Assign dest unwrap_call - -entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem memsize (Imp.Space sid) bt ept dims), e) = do - unpack_input <- asks envEntryInput - unpack <- collect $ unpack_input mem memsize sid bt ept dims e - stms unpack - -extValueDescName :: Imp.ExternalValue -> String -extValueDescName (Imp.TransparentValue v) = extName $ valueDescName v -extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeString desc -extValueDescName (Imp.OpaqueValue desc (v:_)) = - extName $ zEncodeString desc ++ "_" ++ pretty (baseTag (valueDescVName v)) - -extName :: String -> String -extName = (++"_ext") - -sizeOf :: CSType -> CSExp -sizeOf t = simpleCall "sizeof" [(Var . pretty) t] - -publicFunDef :: String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt -publicFunDef s t args stmts = PublicFunDef $ Def s t args stmts - -privateFunDef :: String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt -privateFunDef s t args stmts = PrivateFunDef $ Def s t args stmts - -valueDescName :: Imp.ValueDesc -> String -valueDescName = compileName . valueDescVName - -valueDescVName :: Imp.ValueDesc -> VName -valueDescVName (Imp.ScalarValue _ _ vname) = vname -valueDescVName (Imp.ArrayValue vname _ _ _ _ _) = vname - -consoleWrite :: String -> [CSExp] -> CSExp -consoleWrite str exps = simpleCall "Console.Write" $ String str:exps - -consoleWriteLine :: String -> [CSExp] -> CSExp -consoleWriteLine str exps = simpleCall "Console.WriteLine" $ String str:exps - -consoleErrorWrite :: String -> [CSExp] -> CSExp -consoleErrorWrite str exps = simpleCall "Console.Error.Write" $ String str:exps - -consoleErrorWriteLine :: String -> [CSExp] -> CSExp -consoleErrorWriteLine str exps = simpleCall "Console.Error.WriteLine" $ String str:exps - -readFun :: PrimType -> Imp.Signedness -> String -readFun (FloatType Float32) _ = "ReadF32" -readFun (FloatType Float64) _ = "ReadF64" -readFun (IntType Int8) Imp.TypeUnsigned = "ReadU8" -readFun (IntType Int16) Imp.TypeUnsigned = "ReadU16" -readFun (IntType Int32) Imp.TypeUnsigned = "ReadU32" -readFun (IntType Int64) Imp.TypeUnsigned = "ReadU64" -readFun (IntType Int8) Imp.TypeDirect = "ReadI8" -readFun (IntType Int16) Imp.TypeDirect = "ReadI16" -readFun (IntType Int32) Imp.TypeDirect = "ReadI32" -readFun (IntType Int64) Imp.TypeDirect = "ReadI64" -readFun Imp.Bool _ = "ReadBool" -readFun Cert _ = error "readFun: cert" - -readBinFun :: PrimType -> Imp.Signedness -> String -readBinFun (FloatType Float32) _bin_ = "ReadBinF32" -readBinFun (FloatType Float64) _bin_ = "ReadBinF64" -readBinFun (IntType Int8) Imp.TypeUnsigned = "ReadBinU8" -readBinFun (IntType Int16) Imp.TypeUnsigned = "ReadBinU16" -readBinFun (IntType Int32) Imp.TypeUnsigned = "ReadBinU32" -readBinFun (IntType Int64) Imp.TypeUnsigned = "ReadBinU64" -readBinFun (IntType Int8) Imp.TypeDirect = "ReadBinI8" -readBinFun (IntType Int16) Imp.TypeDirect = "ReadBinI16" -readBinFun (IntType Int32) Imp.TypeDirect = "ReadBinI32" -readBinFun (IntType Int64) Imp.TypeDirect = "ReadBinI64" -readBinFun Imp.Bool _ = "ReadBinBool" -readBinFun Cert _ = error "readFun: cert" - --- The value returned will be used when reading binary arrays, to indicate what --- the expected type is --- Key into the FUTHARK_PRIMTYPES dict. -readTypeEnum :: PrimType -> Imp.Signedness -> String -readTypeEnum (IntType Int8) Imp.TypeUnsigned = "u8" -readTypeEnum (IntType Int16) Imp.TypeUnsigned = "u16" -readTypeEnum (IntType Int32) Imp.TypeUnsigned = "u32" -readTypeEnum (IntType Int64) Imp.TypeUnsigned = "u64" -readTypeEnum (IntType Int8) Imp.TypeDirect = "i8" -readTypeEnum (IntType Int16) Imp.TypeDirect = "i16" -readTypeEnum (IntType Int32) Imp.TypeDirect = "i32" -readTypeEnum (IntType Int64) Imp.TypeDirect = "i64" -readTypeEnum (FloatType Float32) _ = "f32" -readTypeEnum (FloatType Float64) _ = "f64" -readTypeEnum Imp.Bool _ = "bool" -readTypeEnum Cert _ = error "readTypeEnum: cert" - -readInput :: Imp.ExternalValue -> CSStmt -readInput (Imp.OpaqueValue desc _) = - Throw $ simpleInitClass "Exception" [String $ "Cannot read argument of type " ++ desc ++ "."] - -readInput decl@(Imp.TransparentValue (Imp.ScalarValue bt ept _)) = - let read_func = Var $ readFun bt ept - read_bin_func = Var $ readBinFun bt ept - type_enum = String $ readTypeEnum bt ept - bt' = compilePrimTypeExt bt ept - readScalar = initializeGenericFunction "ReadScalar" bt' - in Assign (Var $ extValueDescName decl) $ simpleCall readScalar [type_enum, read_func, read_bin_func] - --- TODO: If the type identifier of 'Float32' is changed, currently the error --- messages for reading binary input will not use this new name. This is also a --- problem for the C runtime system. -readInput decl@(Imp.TransparentValue (Imp.ArrayValue _ _ _ bt ept dims)) = - let rank' = Var $ show $ length dims - type_enum = String $ readTypeEnum bt ept - bt' = compilePrimTypeExt bt ept - read_func = Var $ readFun bt ept - readArray = initializeGenericFunction "ReadArray" bt' - in Assign (Var $ extValueDescName decl) $ simpleCall readArray [rank', type_enum, read_func] - -initializeGenericFunction :: String -> String -> String -initializeGenericFunction fun tp = fun ++ "<" ++ tp ++ ">" - - -printPrimStm :: CSExp -> CSStmt -printPrimStm val = Exp $ simpleCall "WriteValue" [val] - -formatString :: String -> [CSExp] -> CSExp -formatString fmt contents = - simpleCall "String.Format" $ String fmt : contents - -printStm :: Imp.ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt -printStm Imp.ScalarValue{} _ e = - return $ printPrimStm e -printStm (Imp.ArrayValue _ _ _ _ _ []) ind e = do - let e' = Index e (IdxExp (PostUnOp "++" ind)) - return $ printPrimStm e' - -printStm (Imp.ArrayValue mem memsize space bt ept (outer:shape)) ind e = do - ptr <- newVName "shapePtr" - first <- newVName "printFirst" - let size = callMethod (CreateArray (Primitive $ CSInt Int32T) $ map compileDim $ outer:shape) - "Aggregate" [ Integer 1 - , Lambda (Tuple [Var "acc", Var "val"]) - [Exp $ BinOp "*" (Var "acc") (Var "val")] - ] - emptystr = "empty(" ++ ppArrayType bt (length shape) ++ ")" - - printelem <- printStm (Imp.ArrayValue mem memsize space bt ept shape) ind e - return $ - If (BinOp "==" size (Integer 0)) - [puts emptystr] - [ Assign (Var $ pretty first) $ Var "true" - , puts "[" - , For (pretty ptr) (compileDim outer) - [ If (simpleCall "!" [Var $ pretty first]) [puts ", "] [] - , printelem - , Reassign (Var $ pretty first) $ Var "false" - ] - , puts "]" - ] - - where ppArrayType :: PrimType -> Int -> String - ppArrayType t 0 = prettyPrimType ept t - ppArrayType t n = "[]" ++ ppArrayType t (n-1) - - prettyPrimType Imp.TypeUnsigned (IntType Int8) = "u8" - prettyPrimType Imp.TypeUnsigned (IntType Int16) = "u16" - prettyPrimType Imp.TypeUnsigned (IntType Int32) = "u32" - prettyPrimType Imp.TypeUnsigned (IntType Int64) = "u64" - prettyPrimType _ t = pretty t - - puts s = Exp $ simpleCall "Console.Write" [String s] - -printValue :: [(Imp.ExternalValue, CSExp)] -> CompilerM op s [CSStmt] -printValue = fmap concat . mapM (uncurry printValue') - -- We copy non-host arrays to the host before printing. This is - -- done in a hacky way - we assume the value has a .get()-method - -- that returns an equivalent Numpy array. This works for CSOpenCL, - -- but we will probably need yet another plugin mechanism here in - -- the future. - where printValue' (Imp.OpaqueValue desc _) _ = - return [Exp $ simpleCall "Console.Write" - [String $ "#"]] - printValue' (Imp.TransparentValue r@Imp.ScalarValue{}) e = do - p <- printStm r (Integer 0) e - return [p, Exp $ simpleCall "Console.Write" [String "\n"]] - printValue' (Imp.TransparentValue r@Imp.ArrayValue{}) e = do - tuple <- newVName "resultArr" - i <- newVName "arrInd" - let i' = Var $ compileName i - p <- printStm r i' (Var $ compileName tuple) - let e' = Var $ pretty e - return [ Assign (Var $ compileName tuple) (Field e' "Item1") - , Assign i' (Integer 0) - , p - , Exp $ simpleCall "Console.Write" [String "\n"]] - -prepareEntry :: (Name, Imp.Function op) -> CompilerM op s - (String, [(CSType, String)], CSType, [CSStmt], [CSStmt], [CSStmt], [CSStmt], - [(Imp.ExternalValue, CSExp)], [CSStmt]) -prepareEntry (fname, Imp.Function _ outputs inputs _ results args) = do - let (output_types, output_paramNames) = unzip $ map compileTypedInput outputs - funTuple = tupleOrSingle $ fmap Var output_paramNames - - - (_, sizeDecls) <- collect' $ forM args declsfunction - - (argexps_mem_copies, prepare_run) <- collect' $ forM inputs $ \case - Imp.MemParam name space -> do - -- A program might write to its input parameters, so create a new memory - -- block and copy the source there. This way the program can be run more - -- than once. - name' <- newVName $ baseString name <> "_copy" - copy <- asks envCopy - allocate <- asks envAllocate - - let size = Var (compileName name ++ "_nbytes") - dest = name' - src = name - offset = Integer 0 - case space of - DefaultSpace -> - stm $ Reassign (Var (compileName name')) - (simpleCall "allocateMem" [size]) -- FIXME - Space sid -> - allocate name' size sid - copy dest offset space src offset space size (IntType Int64) -- FIXME - return $ Just (compileName name') - _ -> return Nothing - - prepareIn <- collect $ mapM_ entryPointInput $ zip3 [0..] args $ - map (Var . extValueDescName) args - (res, prepareOut) <- collect' $ mapM entryPointOutput results - - let mem_copies = mapMaybe liftMaybe $ zip argexps_mem_copies inputs - mem_copy_inits = map initCopy mem_copies - - argexps_lib = map (compileName . Imp.paramName) inputs - argexps_bin = zipWith fromMaybe argexps_lib argexps_mem_copies - fname' = futharkFun (nameToString fname) - arg_types = map (fst . compileTypedInput) inputs - inputs' = zip arg_types (map extValueDescName args) - output_type = tupleOrSingleEntryT output_types - call_lib = [Reassign funTuple $ simpleCall fname' (fmap Var argexps_lib)] - call_bin = [Reassign funTuple $ simpleCall fname' (fmap Var argexps_bin)] - prepareIn' = prepareIn ++ mem_copy_inits ++ sizeDecls - - return (nameToString fname, inputs', output_type, - prepareIn', call_lib, call_bin, prepareOut, - zip results res, prepare_run) - - where liftMaybe (Just a, b) = Just (a,b) - liftMaybe _ = Nothing - - initCopy (varName, Imp.MemParam _ space) = declMem' varName space - initCopy _ = Pass - - valueDescFun (Imp.ArrayValue mem _ Imp.DefaultSpace _ _ _) = - stm $ Assign (Var $ compileName mem ++ "_nbytes") (Var $ compileName mem ++ ".Length") - valueDescFun (Imp.ArrayValue mem _ (Imp.Space _) bt _ dims) = - stm $ Assign (Var $ compileName mem ++ "_nbytes") $ foldr (BinOp "*" . compileDim) (sizeOf $ compilePrimTypeToAST bt) dims - valueDescFun _ = stm Pass - - declsfunction (Imp.TransparentValue v) = valueDescFun v - declsfunction (Imp.OpaqueValue _ vs) = mapM_ valueDescFun vs - -copyMemoryDefaultSpace :: VName -> CSExp -> VName -> CSExp -> CSExp -> - CompilerM op s () -copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes = - stm $ Exp $ simpleCall "Buffer.BlockCopy" [ Var (compileName srcmem), srcidx - , Var (compileName destmem), destidx, - nbytes] - -compileEntryFun :: [CSStmt] -> (Name, Imp.Function op) - -> CompilerM op s CSFunDef -compileEntryFun pre_timing entry@(_,Imp.Function _ outputs _ _ results args) = do - let params = map (getType &&& extValueDescName) args - let outputType = tupleOrSingleEntryT $ map getType results - - (fname', _, _, prepareIn, body_lib, _, prepareOut, res, _) <- prepareEntry entry - let ret = Return $ tupleOrSingleEntry $ map snd res - let outputDecls = map getDefaultDecl outputs - do_run = body_lib ++ pre_timing - (do_run_with_timing, close_runtime_file) <- addTiming do_run - - let do_warmup_run = If (Var "DoWarmupRun") do_run [] - do_num_runs = For "i" (Var "NumRuns") do_run_with_timing - - return $ Def fname' outputType params $ - prepareIn ++ outputDecls ++ [do_warmup_run, do_num_runs, close_runtime_file] ++ prepareOut ++ [ret] - - where getType :: Imp.ExternalValue -> CSType - getType (Imp.OpaqueValue _ valueDescs) = - let valueDescs' = map getType' valueDescs - in Composite $ SystemTupleT valueDescs' - getType (Imp.TransparentValue valueDesc) = - getType' valueDesc - - getType' :: Imp.ValueDesc -> CSType - getType' (Imp.ScalarValue primtype signedness _) = - compilePrimTypeToASText primtype signedness - getType' (Imp.ArrayValue _ _ _ primtype signedness _) = - let t = compilePrimTypeToASText primtype signedness - in Composite $ SystemTupleT [Composite $ ArrayT t, Composite $ ArrayT $ Primitive $ CSInt Int64T] - - -callEntryFun :: [CSStmt] -> (Name, Imp.Function op) - -> CompilerM op s (CSFunDef, String, CSExp) -callEntryFun pre_timing entry@(fname, Imp.Function _ outputs _ _ _ decl_args) = - if any isOpaque decl_args then - return (Def fname' VoidT [] [exitException], nameToString fname, Var fname') - else do - (_, _, _, prepareIn, _, body_bin, prepare_out, res, prepare_run) <- prepareEntry entry - let str_input = map readInput decl_args - - let outputDecls = map getDefaultDecl outputs - exitcall = [ - Exp $ simpleCall "Console.Error.WriteLine" [formatString "Assertion.{0} failed" [Var "e"]] - , Exp $ simpleCall "Environment.Exit" [Integer 1] - ] - except' = Catch (Var "Exception") exitcall - do_run = body_bin ++ pre_timing - (do_run_with_timing, close_runtime_file) <- addTiming do_run - - -- We ignore overflow errors and the like for executable entry - -- points. These are (somewhat) well-defined in Futhark. - - let maybe_free = - [If (BinOp "<" (Var "i") (BinOp "-" (Var "NumRuns") (Integer 1))) - prepare_out []] - - do_warmup_run = - If (Var "DoWarmupRun") (prepare_run ++ do_run ++ prepare_out) [] - - do_num_runs = - For "i" (Var "NumRuns") (prepare_run ++ do_run_with_timing ++ maybe_free) - - str_output <- printValue res - - return (Def fname' VoidT [] $ - str_input ++ prepareIn ++ outputDecls ++ - [Try [do_warmup_run, do_num_runs] [except']] ++ - [close_runtime_file] ++ - str_output, - - nameToString fname, - - Var fname') - - where fname' = "entry_" ++ nameToString fname - isOpaque Imp.TransparentValue{} = False - isOpaque _ = True - - exitException = Throw $ simpleInitClass "Exception" [String $ "The function " ++ nameToString fname ++ " is not available as an entry function."] - -addTiming :: [CSStmt] -> CompilerM s op ([CSStmt], CSStmt) -addTiming statements = do - syncFun <- asks envSyncFun - - return ([ Assign (Var "StopWatch") $ simpleInitClass "Stopwatch" [] - , syncFun - , Exp $ simpleCall "StopWatch.Start" [] ] ++ - statements ++ - [ syncFun - , Exp $ simpleCall "StopWatch.Stop" [] - , Assign (Var "timeElapsed") $ asMicroseconds (Var "StopWatch") - , If (not_null (Var "RuntimeFile")) [print_runtime] [] - ] - , If (not_null (Var "RuntimeFile")) [ - Exp $ simpleCall "RuntimeFileWriter.Close" [] , - Exp $ simpleCall "RuntimeFile.Close" [] - ] [] - ) - - where print_runtime = Exp $ simpleCall "RuntimeFileWriter.WriteLine" [ callMethod (Var "timeElapsed") "ToString" [] ] - not_null var = BinOp "!=" var Null - asMicroseconds watch = - BinOp "/" (Field watch "ElapsedTicks") - (BinOp "/" (Field (Var "TimeSpan") "TicksPerMillisecond") (Integer 1000)) - -compileUnOp :: Imp.UnOp -> String -compileUnOp op = - case op of - Not -> "!" - Complement{} -> "~" - Abs{} -> "Math.Abs" -- actually write these helpers - FAbs{} -> "Math.Abs" - SSignum{} -> "ssignum" - USignum{} -> "usignum" - -compileBinOpLike :: Monad m => - Imp.Exp -> Imp.Exp - -> CompilerM op s (CSExp, CSExp, String -> m CSExp) -compileBinOpLike x y = do - x' <- compileExp x - y' <- compileExp y - let simple s = return $ BinOp s x' y' - return (x', y', simple) - --- | The ctypes type corresponding to a 'PrimType'. -compilePrimType :: PrimType -> String -compilePrimType t = - case t of - IntType Int8 -> "sbyte" - IntType Int16 -> "short" - IntType Int32 -> "int" - IntType Int64 -> "long" - FloatType Float32 -> "float" - FloatType Float64 -> "double" - Imp.Bool -> "bool" - Cert -> "bool" - --- | The ctypes type corresponding to a 'PrimType', taking sign into account. -compilePrimTypeExt :: PrimType -> Imp.Signedness -> String -compilePrimTypeExt t ept = - case (t, ept) of - (IntType Int8, Imp.TypeUnsigned) -> "byte" - (IntType Int16, Imp.TypeUnsigned) -> "ushort" - (IntType Int32, Imp.TypeUnsigned) -> "uint" - (IntType Int64, Imp.TypeUnsigned) -> "ulong" - (IntType Int8, _) -> "sbyte" - (IntType Int16, _) -> "short" - (IntType Int32, _) -> "int" - (IntType Int64, _) -> "long" - (FloatType Float32, _) -> "float" - (FloatType Float64, _) -> "double" - (Imp.Bool, _) -> "bool" - (Cert, _) -> "byte" - --- | Select function to retrieve bytes from byte array as specific data type --- | The ctypes type corresponding to a 'PrimType'. -compileTypecastExt :: PrimType -> Imp.Signedness -> (CSExp -> CSExp) -compileTypecastExt t ept = - let t' = case (t, ept) of - (IntType Int8 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt8T - (IntType Int16 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt16T - (IntType Int32 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt32T - (IntType Int64 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt64T - (IntType Int8 , _)-> Primitive $ CSInt Int8T - (IntType Int16 , _)-> Primitive $ CSInt Int16T - (IntType Int32 , _)-> Primitive $ CSInt Int32T - (IntType Int64 , _)-> Primitive $ CSInt Int64T - (FloatType Float32, _)-> Primitive $ CSFloat FloatT - (FloatType Float64, _)-> Primitive $ CSFloat DoubleT - (Imp.Bool , _)-> Primitive BoolT - (Cert, _)-> Primitive $ CSInt Int8T - in Cast t' - --- | The ctypes type corresponding to a 'PrimType'. -compileTypecast :: PrimType -> (CSExp -> CSExp) -compileTypecast t = - let t' = case t of - IntType Int8 -> Primitive $ CSInt Int8T - IntType Int16 -> Primitive $ CSInt Int16T - IntType Int32 -> Primitive $ CSInt Int32T - IntType Int64 -> Primitive $ CSInt Int64T - FloatType Float32 -> Primitive $ CSFloat FloatT - FloatType Float64 -> Primitive $ CSFloat DoubleT - Imp.Bool -> Primitive BoolT - Cert -> Primitive $ CSInt Int8T - in Cast t' - --- | The ctypes type corresponding to a 'PrimType'. -compilePrimValue :: Imp.PrimValue -> CSExp -compilePrimValue (IntValue (Int8Value v)) = - Cast (Primitive $ CSInt Int8T) $ Integer $ toInteger v -compilePrimValue (IntValue (Int16Value v)) = - Cast (Primitive $ CSInt Int16T) $ Integer $ toInteger v -compilePrimValue (IntValue (Int32Value v)) = - Cast (Primitive $ CSInt Int32T) $ Integer $ toInteger v -compilePrimValue (IntValue (Int64Value v)) = - Cast (Primitive $ CSInt Int64T) $ Integer $ toInteger v -compilePrimValue (FloatValue (Float32Value v)) - | isInfinite v = - if v > 0 then Var "Single.PositiveInfinity" else Var "Single.NegativeInfinity" - | isNaN v = - Var "Single.NaN" - | otherwise = Cast (Primitive $ CSFloat FloatT) (Float $ fromRational $ toRational v) -compilePrimValue (FloatValue (Float64Value v)) - | isInfinite v = - if v > 0 then Var "Double.PositiveInfinity" else Var "Double.NegativeInfinity" - | isNaN v = - Var "Double.NaN" - | otherwise = Cast (Primitive $ CSFloat DoubleT) (Float $ fromRational $ toRational v) -compilePrimValue (BoolValue v) = Bool v -compilePrimValue Checked = Bool True - -compileExp :: Imp.Exp -> CompilerM op s CSExp - -compileExp (Imp.ValueExp v) = return $ compilePrimValue v - -compileExp (Imp.LeafExp (Imp.ScalarVar vname) _) = - return $ Var $ compileName vname - -compileExp (Imp.LeafExp (Imp.SizeOf t) _) = - return $ (compileTypecast $ IntType Int32) (Integer $ primByteSize t) - -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) (IntType Int8) DefaultSpace _) _) = do - let src' = compileName src - iexp' <- compileExp iexp - return $ Cast (Primitive $ CSInt Int8T) (Index (Var src') (IdxExp iexp')) - -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt DefaultSpace _) _) = do - iexp' <- compileExp iexp - let bt' = compilePrimType bt - return $ simpleCall ("indexArray_" ++ bt') [Var $ compileName src, iexp'] - -compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) = - join $ asks envReadScalar - <*> pure src <*> compileExp iexp - <*> pure restype <*> pure space - -compileExp (Imp.BinOpExp op x y) = do - (x', y', simple) <- compileBinOpLike x y - case op of - FAdd{} -> simple "+" - FSub{} -> simple "-" - FMul{} -> simple "*" - FDiv{} -> simple "/" - LogAnd{} -> simple "&&" - LogOr{} -> simple "||" - _ -> return $ simpleCall (pretty op) [x', y'] - -compileExp (Imp.ConvOpExp conv x) = do - x' <- compileExp x - return $ simpleCall (pretty conv) [x'] - -compileExp (Imp.CmpOpExp cmp x y) = do - (x', y', simple) <- compileBinOpLike x y - case cmp of - CmpEq{} -> simple "==" - FCmpLt{} -> simple "<" - FCmpLe{} -> simple "<=" - _ -> return $ simpleCall (pretty cmp) [x', y'] - -compileExp (Imp.UnOpExp op exp1) = - PreUnOp (compileUnOp op) <$> compileExp exp1 - -compileExp (Imp.FunExp h args _) = - simpleCall (futharkFun (pretty h)) <$> mapM compileExp args - -compileCode :: Imp.Code op -> CompilerM op s () - -compileCode Imp.DebugPrint{} = - return () - -compileCode (Imp.Op op) = - join $ asks envOpCompiler <*> pure op - -compileCode (Imp.If cond tb fb) = do - cond' <- compileExp cond - tb' <- blockScope $ compileCode tb - fb' <- blockScope $ compileCode fb - stm $ If cond' tb' fb' - -compileCode (c1 Imp.:>>: c2) = do - compileCode c1 - compileCode c2 - -compileCode (Imp.While cond body) = do - cond' <- compileExp cond - body' <- blockScope $ compileCode body - stm $ While cond' body' - -compileCode (Imp.For i it bound body) = do - bound' <- compileExp bound - let i' = compileName i - body' <- blockScope $ compileCode body - counter <- pretty <$> newVName "counter" - one <- pretty <$> newVName "one" - stm $ Assign (Var i') $ compileTypecast (IntType it) (Integer 0) - stm $ Assign (Var one) $ compileTypecast (IntType it) (Integer 1) - stm $ For counter bound' $ body' ++ - [AssignOp "+" (Var i') (Var one)] - - -compileCode (Imp.SetScalar vname exp1) = do - let name' = Var $ compileName vname - exp1' <- compileExp exp1 - stm $ Reassign name' exp1' - -compileCode (Imp.DeclareMem v space) = declMem v space - -compileCode (Imp.DeclareScalar v Cert) = - stm $ Assign (Var $ compileName v) $ Bool True -compileCode (Imp.DeclareScalar v t) = - stm $ AssignTyped t' (Var $ compileName v) Nothing - where t' = compilePrimTypeToAST t - -compileCode (Imp.DeclareArray name DefaultSpace t vs) = - stms [Assign (Var $ "init_"++name') $ - simpleCall "unwrapArray" - [ - CreateArray (compilePrimTypeToAST t) (map compilePrimValue vs) - , simpleCall "sizeof" [Var $ compilePrimType t] - ] - , Assign (Var name') $ Var ("init_"++name') - ] - where name' = compileName name - - -compileCode (Imp.DeclareArray name (Space space) t vs) = - join $ asks envStaticArray <*> - pure name <*> pure space <*> pure t <*> pure vs - -compileCode (Imp.Comment s code) = do - code' <- blockScope $ compileCode code - stm $ Comment s code' - -compileCode (Imp.Assert e (Imp.ErrorMsg parts) (loc,locs)) = do - e' <- compileExp e - 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) - where stacktrace = intercalate " -> " (reverse $ map locStr $ loc:locs) - printFormatArg = printf "{%d}" - -compileCode (Imp.Call dests fname args) = do - args' <- mapM compileArg args - let dests' = tupleOrSingle $ fmap Var (map compileName dests) - fname' = futharkFun (pretty fname) - call' = simpleCall fname' args' - -- If the function returns nothing (is called only for side - -- effects), take care not to assign to an empty tuple. - stm $ if null dests - then Exp call' - else Reassign dests' call' - where compileArg (Imp.MemArg m) = return $ Var $ compileName m - compileArg (Imp.ExpArg e) = compileExp e - -compileCode (Imp.SetMem dest src DefaultSpace) = do - let src' = Var (compileName src) - let dest' = Var (compileName dest) - stm $ Reassign dest' src' - -compileCode (Imp.SetMem dest src _) = do - let src' = Var (compileName src) - let dest' = Var (compileName dest) - stm $ Exp $ simpleCall "MemblockSetDevice" [Ref $ Var "Ctx", Ref dest', Ref src', String (compileName src)] - -compileCode (Imp.Allocate name (Imp.Count e) DefaultSpace) = do - e' <- compileExp e - let allocate' = simpleCall "allocateMem" [e'] - let name' = Var (compileName name) - stm $ Reassign name' allocate' - -compileCode (Imp.Allocate name (Imp.Count e) (Imp.Space space)) = - join $ asks envAllocate - <*> pure name - <*> compileExp e - <*> pure space - -compileCode (Imp.Free name space) = do - unRefMem name space - tell $ mempty { accFreedMem = [name] } - -compileCode (Imp.Copy dest (Imp.Count destoffset) DefaultSpace src (Imp.Count srcoffset) DefaultSpace (Imp.Count size)) = do - destoffset' <- compileExp destoffset - srcoffset' <- compileExp srcoffset - let dest' = Var (compileName dest) - let src' = Var (compileName src) - size' <- compileExp size - stm $ Exp $ simpleCall "Buffer.BlockCopy" [src', srcoffset', dest', destoffset', size'] - -compileCode (Imp.Copy dest (Imp.Count destoffset) destspace src (Imp.Count srcoffset) srcspace (Imp.Count size)) = do - copy <- asks envCopy - join $ copy - <$> pure dest <*> compileExp destoffset <*> pure destspace - <*> pure src <*> compileExp srcoffset <*> pure srcspace - <*> compileExp size <*> pure (IntType Int64) -- FIXME - -compileCode (Imp.Write dest (Imp.Count idx) elemtype DefaultSpace _ elemexp) = do - idx' <- compileExp idx - elemexp' <- compileExp elemexp - let dest' = Var $ compileName dest - let elemtype' = compileTypecast elemtype - let ctype = elemtype' elemexp' - stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', ctype] - -compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) = - join $ asks envWriteScalar - <*> pure dest - <*> compileExp idx - <*> pure elemtype - <*> pure space - <*> compileExp elemexp - -compileCode Imp.Skip = return () - -blockScope :: CompilerM op s () -> CompilerM op s [CSStmt] -blockScope = fmap snd . blockScope' - -blockScope' :: CompilerM op s a -> CompilerM op s (a, [CSStmt]) -blockScope' m = do - old_allocs <- gets compDeclaredMem - (x, items) <- pass $ do - (x, w) <- listen m - let items = accItems w - return ((x, items), const mempty) - new_allocs <- gets $ filter (`notElem` old_allocs) . compDeclaredMem - modify $ \s -> s { compDeclaredMem = old_allocs } - releases <- collect $ mapM_ (uncurry unRefMem) new_allocs - return (x, items <> releases) - -unRefMem :: VName -> Space -> CompilerM op s () -unRefMem mem (Space "device") = - (stm . Exp) $ simpleCall "MemblockUnrefDevice" [ Ref $ Var "Ctx" - , (Ref . Var . compileName) mem - , (String . compileName) mem] -unRefMem _ DefaultSpace = stm Pass -unRefMem _ (Space "local") = stm Pass -unRefMem _ (Space _) = fail "The default compiler cannot compile unRefMem for other spaces" - - --- | Public names must have a consistent prefix. -publicName :: String -> String -publicName s = "Futhark" ++ s - -declMem :: VName -> Space -> CompilerM op s () -declMem name space = do - modify $ \s -> s { compDeclaredMem = (name, space) : compDeclaredMem s} - stm $ declMem' (compileName name) space - -declMem' :: String -> Space -> CSStmt -declMem' name DefaultSpace = - AssignTyped (Composite $ ArrayT $ Primitive ByteT) (Var name) Nothing -declMem' name (Space _) = - AssignTyped (CustomT "OpenCLMemblock") (Var name) (Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"]) - -rawMemCSType :: Space -> CSType -rawMemCSType DefaultSpace = Composite $ ArrayT $ Primitive ByteT -rawMemCSType (Space _) = CustomT "OpenCLMemblock" - -toIntPtr :: CSExp -> CSExp -toIntPtr e = simpleInitClass "IntPtr" [e] +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, LambdaCase #-} +{-# LANGUAGE TupleSections #-} +-- | A generic C# code generator which is polymorphic in the type +-- of the operations. Concretely, we use this to handle both +-- sequential and OpenCL C# code. +module Futhark.CodeGen.Backends.GenericCSharp + ( compileProg + , Constructor (..) + , emptyConstructor + + , assignScalarPointer + , toIntPtr + , compileName + , compileDim + , compileExp + , compileCode + , compilePrimValue + , compilePrimType + , compilePrimTypeExt + , compilePrimTypeToAST + , compilePrimTypeToASText + , contextFinalInits + , debugReport + + , Operations (..) + , defaultOperations + + , unpackDim + + , CompilerM (..) + , OpCompiler + , WriteScalar + , ReadScalar + , Allocate + , Copy + , StaticArray + , EntryOutput + , EntryInput + + , CompilerEnv(..) + , CompilerState(..) + , stm + , stms + , atInit + , staticMemDecl + , staticMemAlloc + , addMemberDecl + , beforeParse + , collect' + , collect + , simpleCall + , callMethod + , simpleInitClass + , parametrizedCall + + , copyMemoryDefaultSpace + , consoleErrorWrite + , consoleErrorWriteLine + , consoleWrite + , consoleWriteLine + + , publicName + , sizeOf + , privateFunDef + , publicFunDef + , getDefaultDecl + ) where + +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.RWS +import Control.Arrow((&&&)) +import Data.Maybe +import Data.List +import qualified Data.Map.Strict as M + +import Futhark.Representation.Primitive hiding (Bool) +import Futhark.MonadFreshNames +import Futhark.Representation.AST.Syntax (Space(..)) +import qualified Futhark.CodeGen.ImpCode as Imp +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) + +-- | A substitute expression compiler, tried before the main +-- compilation function. +type OpCompiler op s = op -> CompilerM op s () + +-- | Write a scalar to the given memory block with the given index and +-- in the given memory space. +type WriteScalar op s = VName -> CSExp -> PrimType -> Imp.SpaceId -> CSExp + -> CompilerM op s () + +-- | Read a scalar from the given memory block with the given index and +-- in the given memory space. +type ReadScalar op s = VName -> CSExp -> PrimType -> Imp.SpaceId + -> CompilerM op s CSExp + +-- | Allocate a memory block of the given size in the given memory +-- space, saving a reference in the given variable name. +type Allocate op s = VName -> CSExp -> Imp.SpaceId + -> CompilerM op s () + +-- | Copy from one memory block to another. +type Copy op s = VName -> CSExp -> Imp.Space -> + VName -> CSExp -> Imp.Space -> + CSExp -> PrimType -> + CompilerM op s () + +-- | Create a static array of values - initialised at load time. +type StaticArray op s = VName -> Imp.SpaceId -> PrimType -> [PrimValue] -> CompilerM op s () + +-- | Construct the C# array being returned from an entry point. +type EntryOutput op s = VName -> Imp.SpaceId -> + PrimType -> Imp.Signedness -> + [Imp.DimSize] -> + CompilerM op s CSExp + +-- | Unpack the array being passed to an entry point. +type EntryInput op s = VName -> Imp.MemSize -> Imp.SpaceId -> + PrimType -> Imp.Signedness -> + [Imp.DimSize] -> + CSExp -> + CompilerM op s () + +data Operations op s = Operations { opsWriteScalar :: WriteScalar op s + , opsReadScalar :: ReadScalar op s + , opsAllocate :: Allocate op s + , opsCopy :: Copy op s + , opsStaticArray :: StaticArray op s + , opsCompiler :: OpCompiler op s + , opsEntryOutput :: EntryOutput op s + , opsEntryInput :: EntryInput op s + , opsSyncRun :: CSStmt + } + +-- | A set of operations that fail for every operation involving +-- non-default memory spaces. Uses plain pointers and @malloc@ for +-- memory management. +defaultOperations :: Operations op s +defaultOperations = Operations { opsWriteScalar = defWriteScalar + , opsReadScalar = defReadScalar + , opsAllocate = defAllocate + , opsCopy = defCopy + , opsStaticArray = defStaticArray + , opsCompiler = defCompiler + , opsEntryOutput = defEntryOutput + , opsEntryInput = defEntryInput + , opsSyncRun = defSyncRun + } + where defWriteScalar _ _ _ _ _ = + fail "Cannot write to non-default memory space because I am dumb" + defReadScalar _ _ _ _ = + fail "Cannot read from non-default memory space" + defAllocate _ _ _ = + fail "Cannot allocate in non-default memory space" + defCopy _ _ _ _ _ _ _ _ = + fail "Cannot copy to or from non-default memory space" + defStaticArray _ _ _ _ = + fail "Cannot create static array in non-default memory space" + defCompiler _ = + fail "The default compiler cannot compile extended operations" + defEntryOutput _ _ _ _ = + fail "Cannot return array not in default memory space" + defEntryInput _ _ _ _ = + fail "Cannot accept array not in default memory space" + defSyncRun = + Pass + +data CompilerEnv op s = CompilerEnv { + envOperations :: Operations op s + , envFtable :: M.Map Name [Imp.Type] +} + +data CompilerAcc op s = CompilerAcc { + accItems :: [CSStmt] + , accFreedMem :: [VName] + } + +instance Semigroup (CompilerAcc op s) where + CompilerAcc items1 freed1 <> CompilerAcc items2 freed2 = + CompilerAcc (items1<>items2) (freed1<>freed2) + +instance Monoid (CompilerAcc op s) where + mempty = CompilerAcc mempty mempty + +envOpCompiler :: CompilerEnv op s -> OpCompiler op s +envOpCompiler = opsCompiler . envOperations + +envReadScalar :: CompilerEnv op s -> ReadScalar op s +envReadScalar = opsReadScalar . envOperations + +envWriteScalar :: CompilerEnv op s -> WriteScalar op s +envWriteScalar = opsWriteScalar . envOperations + +envAllocate :: CompilerEnv op s -> Allocate op s +envAllocate = opsAllocate . envOperations + +envCopy :: CompilerEnv op s -> Copy op s +envCopy = opsCopy . envOperations + +envStaticArray :: CompilerEnv op s -> StaticArray op s +envStaticArray = opsStaticArray . envOperations + +envEntryOutput :: CompilerEnv op s -> EntryOutput op s +envEntryOutput = opsEntryOutput . envOperations + +envEntryInput :: CompilerEnv op s -> EntryInput op s +envEntryInput = opsEntryInput . envOperations + +envSyncFun :: CompilerEnv op s -> CSStmt +envSyncFun = opsSyncRun . envOperations + +newCompilerEnv :: Imp.Functions op -> Operations op s -> CompilerEnv op s +newCompilerEnv (Imp.Functions funs) ops = + CompilerEnv { envOperations = ops + , envFtable = ftable <> builtinFtable + } + where ftable = M.fromList $ map funReturn funs + funReturn (name, Imp.Function _ outparams _ _ _ _) = (name, paramsTypes outparams) + builtinFtable = M.map (map Imp.Scalar . snd) builtInFunctions + +data CompilerState s = CompilerState { + compNameSrc :: VNameSource + , compBeforeParse :: [CSStmt] + , compInit :: [CSStmt] + , compStaticMemDecls :: [CSStmt] + , compStaticMemAllocs :: [CSStmt] + , compDebugItems :: [CSStmt] + , compUserState :: s + , compMemberDecls :: [CSStmt] + , compAssignedVars :: [VName] + , compDeclaredMem :: [(VName, Space)] +} + +newCompilerState :: VNameSource -> s -> CompilerState s +newCompilerState src s = CompilerState { compNameSrc = src + , compBeforeParse = [] + , compInit = [] + , compStaticMemDecls = [] + , compStaticMemAllocs = [] + , compDebugItems = [] + , compMemberDecls = [] + , compUserState = s + , compAssignedVars = [] + , compDeclaredMem = [] + } + +newtype CompilerM op s a = CompilerM (RWS (CompilerEnv op s) (CompilerAcc op s) (CompilerState s) a) + deriving (Functor, Applicative, Monad, + MonadState (CompilerState s), + MonadReader (CompilerEnv op s), + MonadWriter (CompilerAcc op s)) + +instance MonadFreshNames (CompilerM op s) where + getNameSource = gets compNameSrc + putNameSource src = modify $ \s -> s { compNameSrc = src } + +collect :: CompilerM op s () -> CompilerM op s [CSStmt] +collect m = pass $ do + ((), w) <- listen m + return (accItems w, + const w { accItems = mempty} ) + +collect' :: CompilerM op s a -> CompilerM op s (a, [CSStmt]) +collect' m = pass $ do + (x, w) <- listen m + return ((x, accItems w), + const w { accItems = mempty}) + +beforeParse :: CSStmt -> CompilerM op s () +beforeParse x = modify $ \s -> + s { compBeforeParse = compBeforeParse s ++ [x] } + +atInit :: CSStmt -> CompilerM op s () +atInit x = modify $ \s -> + s { compInit = compInit s ++ [x] } + +staticMemDecl :: CSStmt -> CompilerM op s () +staticMemDecl x = modify $ \s -> + s { compStaticMemDecls = compStaticMemDecls s ++ [x] } + +staticMemAlloc :: CSStmt -> CompilerM op s () +staticMemAlloc x = modify $ \s -> + s { compStaticMemAllocs = compStaticMemAllocs s ++ [x] } + +addMemberDecl :: CSStmt -> CompilerM op s () +addMemberDecl x = modify $ \s -> + s { compMemberDecls = compMemberDecls s ++ [x] } + +contextFinalInits :: CompilerM op s [CSStmt] +contextFinalInits = gets compInit + +item :: CSStmt -> CompilerM op s () +item x = tell $ mempty { accItems = [x] } + +stm :: CSStmt -> CompilerM op s () +stm = item + +stms :: [CSStmt] -> CompilerM op s () +stms = mapM_ stm + +debugReport :: CSStmt -> CompilerM op s () +debugReport x = modify $ \s -> + s { compDebugItems = compDebugItems s ++ [x] } + +getVarAssigned :: VName -> CompilerM op s Bool +getVarAssigned vname = + elem vname <$> gets compAssignedVars + +setVarAssigned :: VName -> CompilerM op s () +setVarAssigned vname = modify $ \s -> + s { compAssignedVars = vname : compAssignedVars s} + +futharkFun :: String -> String +futharkFun s = "futhark_" ++ zEncodeString s + +paramsTypes :: [Imp.Param] -> [Imp.Type] +paramsTypes = map paramType + +paramType :: Imp.Param -> Imp.Type +paramType (Imp.MemParam _ space) = Imp.Mem (Imp.ConstSize 0) space +paramType (Imp.ScalarParam _ t) = Imp.Scalar t + +compileOutput :: Imp.Param -> (CSExp, CSType) +compileOutput = nameFun &&& typeFun + where nameFun = Var . compileName . Imp.paramName + typeFun = compileType . paramType + +getDefaultDecl :: Imp.Param -> CSStmt +getDefaultDecl (Imp.MemParam v DefaultSpace) = + Assign (Var $ compileName v) $ simpleCall "allocateMem" [Integer 0] +getDefaultDecl (Imp.MemParam v _) = + AssignTyped (CustomT "OpenCLMemblock") (Var $ compileName v) (Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"]) +getDefaultDecl (Imp.ScalarParam v Cert) = + Assign (Var $ compileName v) $ Bool True +getDefaultDecl (Imp.ScalarParam v t) = + Assign (Var $ compileName v) $ simpleInitClass (compilePrimType t) [] + + +runCompilerM :: Imp.Functions op -> Operations op s + -> VNameSource + -> s + -> CompilerM op s a + -> a +runCompilerM prog ops src userstate (CompilerM m) = + fst $ evalRWS m (newCompilerEnv prog ops) (newCompilerState src userstate) + +standardOptions :: [Option] +standardOptions = [ + Option { optionLongName = "write-runtime-to" + , optionShortName = Just 't' + , optionArgument = RequiredArgument + , optionAction = + [ + If (BinOp "!=" (Var "RuntimeFile") Null) + [Exp $ simpleCall "RuntimeFile.Close" []] [] + , Reassign (Var "RuntimeFile") $ + simpleInitClass "FileStream" [Var "optarg", Var "FileMode.Create"] + , Reassign (Var "RuntimeFileWriter") $ + simpleInitClass "StreamWriter" [Var "RuntimeFile"] + ] + }, + Option { optionLongName = "runs" + , optionShortName = Just 'r' + , optionArgument = RequiredArgument + , optionAction = + [ Reassign (Var "NumRuns") $ simpleCall "Convert.ToInt32" [Var "optarg"] + , Reassign (Var "DoWarmupRun") $ Bool True + ] + }, + Option { optionLongName = "entry-point" + , optionShortName = Just 'e' + , optionArgument = RequiredArgument + , optionAction = + [ Reassign (Var "EntryPoint") $ Var "optarg" ] + } + ] + +-- | The class generated by the code generator must have a +-- constructor, although it can be vacuous. +data Constructor = Constructor [CSFunDefArg] [CSStmt] + +-- | A constructor that takes no arguments and does nothing. +emptyConstructor :: Constructor +emptyConstructor = Constructor [(Composite $ ArrayT $ Primitive StringT, "args")] [] + +constructorToConstructorDef :: Constructor -> String -> [CSStmt] -> CSStmt +constructorToConstructorDef (Constructor params body) name at_init = + ConstructorDef $ ClassConstructor name params $ body <> at_init + + +compileProg :: MonadFreshNames m => + Maybe String + -> Constructor + -> [CSStmt] + -> [CSStmt] + -> Operations op s + -> s + -> CompilerM op s () + -> [CSStmt] + -> [Space] + -> [Option] + -> Imp.Functions op + -> m String +compileProg module_name constructor imports defines ops userstate boilerplate pre_timing _ options prog@(Imp.Functions funs) = do + src <- getNameSource + let prog' = runCompilerM prog ops src userstate compileProg' + let imports' = [ Using Nothing "System" + , Using Nothing "System.Diagnostics" + , Using Nothing "System.Collections" + , Using Nothing "System.Collections.Generic" + , Using Nothing "System.IO" + , Using Nothing "System.Linq" + , Using Nothing "System.Runtime.InteropServices" + , Using Nothing "static System.ValueTuple" + , Using Nothing "static System.Convert" + , Using Nothing "static System.Math" + , Using Nothing "System.Numerics" + , Using Nothing "Mono.Options" ] ++ imports + + return $ pretty (CSProg $ imports' ++ prog') + where compileProg' = do + definitions <- mapM compileFunc funs + opencl_boilerplate <- collect boilerplate + compBeforeParses <- gets compBeforeParse + compInits <- gets compInit + staticDecls <- gets compStaticMemDecls + staticAllocs <- gets compStaticMemAllocs + extraMemberDecls <- gets compMemberDecls + let member_decls' = member_decls ++ extraMemberDecls ++ staticDecls + let at_inits' = at_inits ++ compBeforeParses ++ parse_options ++ compInits ++ staticAllocs + + + case module_name of + Just name -> do + entry_points <- mapM (compileEntryFun pre_timing) $ filter (Imp.functionEntry . snd) funs + let constructor' = constructorToConstructorDef constructor name at_inits' + return [ Namespace name [ClassDef $ PublicClass name $ member_decls' ++ + constructor' : defines' ++ opencl_boilerplate ++ + map PrivateFunDef definitions ++ + map PublicFunDef entry_points ]] + + + Nothing -> do + let name = "FutharkInternal" + let constructor' = constructorToConstructorDef constructor name at_inits' + (entry_point_defs, entry_point_names, entry_points) <- + unzip3 <$> mapM (callEntryFun pre_timing) + (filter (Imp.functionEntry . snd) funs) + + debug_ending <- gets compDebugItems + return [Namespace name ((ClassDef $ + PublicClass name $ + member_decls' ++ + constructor' : defines' ++ + opencl_boilerplate ++ + map PrivateFunDef (definitions ++ entry_point_defs) ++ + [PublicFunDef $ Def "InternalEntry" VoidT [] $ selectEntryPoint entry_point_names entry_points ++ debug_ending + ] + ) : + [ClassDef $ PublicClass "Program" + [StaticFunDef $ Def "Main" VoidT [(string_arrayT,"args")] main_entry]]) + ] + + + + string_arrayT = Composite $ ArrayT $ Primitive StringT + main_entry :: [CSStmt] + main_entry = [ Assign (Var "internalInstance") (simpleInitClass "FutharkInternal" [Var "args"]) + , Exp $ simpleCall "internalInstance.InternalEntry" [] + ] + + member_decls = + [ AssignTyped (CustomT "FileStream") (Var "RuntimeFile") Nothing + , AssignTyped (CustomT "StreamWriter") (Var "RuntimeFileWriter") Nothing + , AssignTyped (Primitive BoolT) (Var "DoWarmupRun") Nothing + , AssignTyped (Primitive $ CSInt Int32T) (Var "NumRuns") Nothing + , AssignTyped (Primitive StringT) (Var "EntryPoint") Nothing + ] + + at_inits = [ Reassign (Var "DoWarmupRun") (Bool False) + , Reassign (Var "NumRuns") (Integer 1) + , Reassign (Var "EntryPoint") (String "main") + , Exp $ simpleCall "ValueReader" [] + ] + + defines' = [ Escape csScalar + , Escape csMemory + , Escape csPanic + , Escape csExceptions + , Escape csReader] ++ defines + + parse_options = + generateOptionParser (standardOptions ++ options) + + selectEntryPoint entry_point_names entry_points = + [ Assign (Var "EntryPoints") $ + Collection "Dictionary" $ zipWith Pair (map String entry_point_names) entry_points, + If (simpleCall "!EntryPoints.ContainsKey" [Var "EntryPoint"]) + [ Exp $ simpleCall "Console.Error.WriteLine" + [simpleCall "string.Format" + [ String "No entry point '{0}'. Select another with --entry point. Options are:\n{1}" + , Var "EntryPoint" + , simpleCall "string.Join" + [ String "\n" + , Field (Var "EntryPoints") "Keys" ]]] + , Exp $ simpleCall "Environment.Exit" [Integer 1]] + [ Assign (Var "entryPointFun") $ + Index (Var "EntryPoints") (IdxExp $ Var "EntryPoint") + , Exp $ simpleCall "entryPointFun.Invoke" []] + ] + + +compileFunc :: (Name, Imp.Function op) -> CompilerM op s CSFunDef +compileFunc (fname, Imp.Function _ outputs inputs body _ _) = do + body' <- blockScope $ compileCode body + let inputs' = map compileTypedInput inputs + let outputs' = map compileOutput outputs + let outputDecls = map getDefaultDecl outputs + let (ret, retType) = unzip outputs' + let retType' = tupleOrSingleT retType + let ret' = [Return $ tupleOrSingle ret] + + case outputs of + [] -> return $ Def (futharkFun . nameToString $ fname) VoidT inputs' (outputDecls++body') + _ -> return $ Def (futharkFun . nameToString $ fname) retType' inputs' (outputDecls++body'++ret') + + +compileTypedInput :: Imp.Param -> (CSType, String) +compileTypedInput input = (typeFun input, nameFun input) + where nameFun = compileName . Imp.paramName + typeFun = compileType . paramType + +tupleOrSingleEntryT :: [CSType] -> CSType +tupleOrSingleEntryT [e] = e +tupleOrSingleEntryT es = Composite $ SystemTupleT es + +tupleOrSingleEntry :: [CSExp] -> CSExp +tupleOrSingleEntry [e] = e +tupleOrSingleEntry es = CreateSystemTuple es + +tupleOrSingleT :: [CSType] -> CSType +tupleOrSingleT [e] = e +tupleOrSingleT es = Composite $ TupleT es + +tupleOrSingle :: [CSExp] -> CSExp +tupleOrSingle [e] = e +tupleOrSingle es = Tuple es + +assignScalarPointer :: CSExp -> CSExp -> CSStmt +assignScalarPointer e ptr = + AssignTyped (PointerT VoidT) ptr (Just $ Addr e) + +-- | A 'Call' where the function is a variable and every argument is a +-- simple 'Arg'. +simpleCall :: String -> [CSExp] -> CSExp +simpleCall fname = Call (Var fname) . map simpleArg + +-- | A 'Call' where the function is a variable and every argument is a +-- simple 'Arg'. +parametrizedCall :: String -> String -> [CSExp] -> CSExp +parametrizedCall fname primtype = Call (Var fname') . map simpleArg + where fname' = concat [fname, "<", primtype, ">"] + +simpleArg :: CSExp -> CSArg +simpleArg = Arg Nothing + +-- | A CallMethod +callMethod :: CSExp -> String -> [CSExp] -> CSExp +callMethod object method = CallMethod object (Var method) . map simpleArg + +simpleInitClass :: String -> [CSExp] -> CSExp +simpleInitClass fname =CreateObject (Var fname) . map simpleArg + +compileName :: VName -> String +compileName = zEncodeString . pretty + +compileType :: Imp.Type -> CSType +compileType (Imp.Scalar p) = compilePrimTypeToAST p +compileType (Imp.Mem _ space) = rawMemCSType space + +compilePrimTypeToAST :: PrimType -> CSType +compilePrimTypeToAST (IntType Int8) = Primitive $ CSInt Int8T +compilePrimTypeToAST (IntType Int16) = Primitive $ CSInt Int16T +compilePrimTypeToAST (IntType Int32) = Primitive $ CSInt Int32T +compilePrimTypeToAST (IntType Int64) = Primitive $ CSInt Int64T +compilePrimTypeToAST (FloatType Float32) = Primitive $ CSFloat FloatT +compilePrimTypeToAST (FloatType Float64) = Primitive $ CSFloat DoubleT +compilePrimTypeToAST Imp.Bool = Primitive BoolT +compilePrimTypeToAST Imp.Cert = Primitive BoolT + +compilePrimTypeToASText :: PrimType -> Imp.Signedness -> CSType +compilePrimTypeToASText (IntType Int8) Imp.TypeUnsigned = Primitive $ CSUInt UInt8T +compilePrimTypeToASText (IntType Int16) Imp.TypeUnsigned = Primitive $ CSUInt UInt16T +compilePrimTypeToASText (IntType Int32) Imp.TypeUnsigned = Primitive $ CSUInt UInt32T +compilePrimTypeToASText (IntType Int64) Imp.TypeUnsigned = Primitive $ CSUInt UInt64T +compilePrimTypeToASText (IntType Int8) _ = Primitive $ CSInt Int8T +compilePrimTypeToASText (IntType Int16) _ = Primitive $ CSInt Int16T +compilePrimTypeToASText (IntType Int32) _ = Primitive $ CSInt Int32T +compilePrimTypeToASText (IntType Int64) _ = Primitive $ CSInt Int64T +compilePrimTypeToASText (FloatType Float32) _ = Primitive $ CSFloat FloatT +compilePrimTypeToASText (FloatType Float64) _ = Primitive $ CSFloat DoubleT +compilePrimTypeToASText Imp.Bool _ = Primitive BoolT +compilePrimTypeToASText Imp.Cert _ = Primitive BoolT + +compileDim :: Imp.DimSize -> CSExp +compileDim (Imp.ConstSize i) = Integer $ toInteger i +compileDim (Imp.VarSize v) = Var $ compileName v + +unpackDim :: CSExp -> Imp.DimSize -> Int32 -> CompilerM op s () +unpackDim arr_name (Imp.ConstSize c) i = do + let shape_name = Field arr_name "Item2" -- array tuples are currently (data array * dimension array) currently + let constant_c = Integer $ toInteger c + let constant_i = Integer $ toInteger i + stm $ Assert (BinOp "==" constant_c (Index shape_name $ IdxExp constant_i)) [String "constant dimension wrong"] + +unpackDim arr_name (Imp.VarSize var) i = do + let shape_name = Field arr_name "Item2" + let src = Index shape_name $ IdxExp $ Integer $ toInteger i + let dest = Var $ compileName var + isAssigned <- getVarAssigned var + if isAssigned + then + stm $ Reassign dest $ Cast (Primitive $ CSInt Int32T) src + else do + stm $ Assign dest $ Cast (Primitive $ CSInt Int32T) src + setVarAssigned var + +entryPointOutput :: Imp.ExternalValue -> CompilerM op s CSExp +entryPointOutput (Imp.OpaqueValue _ vs) = + CreateSystemTuple <$> mapM (entryPointOutput . Imp.TransparentValue) vs + +entryPointOutput (Imp.TransparentValue (Imp.ScalarValue bt ept name)) = + return $ cast $ Var $ compileName name + where cast = compileTypecastExt bt ept + +entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ Imp.DefaultSpace bt ept dims)) = do + let src = Var $ compileName mem + let createTuple = "createTuple_" ++ compilePrimTypeExt bt ept + return $ simpleCall createTuple [src, CreateArray (Primitive $ CSInt Int64T) $ map compileDim dims] + +entryPointOutput (Imp.TransparentValue (Imp.ArrayValue mem _ (Imp.Space sid) bt ept dims)) = do + unRefMem mem (Imp.Space sid) + pack_output <- asks envEntryOutput + pack_output mem sid bt ept dims + +entryPointInput :: (Int, Imp.ExternalValue, CSExp) -> CompilerM op s () +entryPointInput (i, Imp.OpaqueValue _ vs, e) = + mapM_ entryPointInput $ zip3 (repeat i) (map Imp.TransparentValue vs) $ + map (\idx -> Field e $ "Item" ++ show (idx :: Int)) [1..] + +entryPointInput (_, Imp.TransparentValue (Imp.ScalarValue bt _ name), e) = do + let vname' = Var $ compileName name + cast = compileTypecast bt + stm $ Assign vname' (cast e) + +entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem memsize Imp.DefaultSpace bt _ dims), e) = do + zipWithM_ (unpackDim e) dims [0..] + let arrayData = Field e "Item1" + let dest = Var $ compileName mem + unwrap_call = simpleCall "unwrapArray" [arrayData, sizeOf $ compilePrimTypeToAST bt] + case memsize of + Imp.VarSize sizevar -> + stm $ Assign (Var $ compileName sizevar) $ Field e "Item2.Length" + Imp.ConstSize _ -> + return () + stm $ Assign dest unwrap_call + +entryPointInput (_, Imp.TransparentValue (Imp.ArrayValue mem memsize (Imp.Space sid) bt ept dims), e) = do + unpack_input <- asks envEntryInput + unpack <- collect $ unpack_input mem memsize sid bt ept dims e + stms unpack + +extValueDescName :: Imp.ExternalValue -> String +extValueDescName (Imp.TransparentValue v) = extName $ valueDescName v +extValueDescName (Imp.OpaqueValue desc []) = extName $ zEncodeString desc +extValueDescName (Imp.OpaqueValue desc (v:_)) = + extName $ zEncodeString desc ++ "_" ++ pretty (baseTag (valueDescVName v)) + +extName :: String -> String +extName = (++"_ext") + +sizeOf :: CSType -> CSExp +sizeOf t = simpleCall "sizeof" [(Var . pretty) t] + +publicFunDef :: String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt +publicFunDef s t args stmts = PublicFunDef $ Def s t args stmts + +privateFunDef :: String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt +privateFunDef s t args stmts = PrivateFunDef $ Def s t args stmts + +valueDescName :: Imp.ValueDesc -> String +valueDescName = compileName . valueDescVName + +valueDescVName :: Imp.ValueDesc -> VName +valueDescVName (Imp.ScalarValue _ _ vname) = vname +valueDescVName (Imp.ArrayValue vname _ _ _ _ _) = vname + +consoleWrite :: String -> [CSExp] -> CSExp +consoleWrite str exps = simpleCall "Console.Write" $ String str:exps + +consoleWriteLine :: String -> [CSExp] -> CSExp +consoleWriteLine str exps = simpleCall "Console.WriteLine" $ String str:exps + +consoleErrorWrite :: String -> [CSExp] -> CSExp +consoleErrorWrite str exps = simpleCall "Console.Error.Write" $ String str:exps + +consoleErrorWriteLine :: String -> [CSExp] -> CSExp +consoleErrorWriteLine str exps = simpleCall "Console.Error.WriteLine" $ String str:exps + +readFun :: PrimType -> Imp.Signedness -> String +readFun (FloatType Float32) _ = "ReadF32" +readFun (FloatType Float64) _ = "ReadF64" +readFun (IntType Int8) Imp.TypeUnsigned = "ReadU8" +readFun (IntType Int16) Imp.TypeUnsigned = "ReadU16" +readFun (IntType Int32) Imp.TypeUnsigned = "ReadU32" +readFun (IntType Int64) Imp.TypeUnsigned = "ReadU64" +readFun (IntType Int8) Imp.TypeDirect = "ReadI8" +readFun (IntType Int16) Imp.TypeDirect = "ReadI16" +readFun (IntType Int32) Imp.TypeDirect = "ReadI32" +readFun (IntType Int64) Imp.TypeDirect = "ReadI64" +readFun Imp.Bool _ = "ReadBool" +readFun Cert _ = error "readFun: cert" + +readBinFun :: PrimType -> Imp.Signedness -> String +readBinFun (FloatType Float32) _bin_ = "ReadBinF32" +readBinFun (FloatType Float64) _bin_ = "ReadBinF64" +readBinFun (IntType Int8) Imp.TypeUnsigned = "ReadBinU8" +readBinFun (IntType Int16) Imp.TypeUnsigned = "ReadBinU16" +readBinFun (IntType Int32) Imp.TypeUnsigned = "ReadBinU32" +readBinFun (IntType Int64) Imp.TypeUnsigned = "ReadBinU64" +readBinFun (IntType Int8) Imp.TypeDirect = "ReadBinI8" +readBinFun (IntType Int16) Imp.TypeDirect = "ReadBinI16" +readBinFun (IntType Int32) Imp.TypeDirect = "ReadBinI32" +readBinFun (IntType Int64) Imp.TypeDirect = "ReadBinI64" +readBinFun Imp.Bool _ = "ReadBinBool" +readBinFun Cert _ = error "readFun: cert" + +-- The value returned will be used when reading binary arrays, to indicate what +-- the expected type is +-- Key into the FUTHARK_PRIMTYPES dict. +readTypeEnum :: PrimType -> Imp.Signedness -> String +readTypeEnum (IntType Int8) Imp.TypeUnsigned = "u8" +readTypeEnum (IntType Int16) Imp.TypeUnsigned = "u16" +readTypeEnum (IntType Int32) Imp.TypeUnsigned = "u32" +readTypeEnum (IntType Int64) Imp.TypeUnsigned = "u64" +readTypeEnum (IntType Int8) Imp.TypeDirect = "i8" +readTypeEnum (IntType Int16) Imp.TypeDirect = "i16" +readTypeEnum (IntType Int32) Imp.TypeDirect = "i32" +readTypeEnum (IntType Int64) Imp.TypeDirect = "i64" +readTypeEnum (FloatType Float32) _ = "f32" +readTypeEnum (FloatType Float64) _ = "f64" +readTypeEnum Imp.Bool _ = "bool" +readTypeEnum Cert _ = error "readTypeEnum: cert" + +readInput :: Imp.ExternalValue -> CSStmt +readInput (Imp.OpaqueValue desc _) = + Throw $ simpleInitClass "Exception" [String $ "Cannot read argument of type " ++ desc ++ "."] + +readInput decl@(Imp.TransparentValue (Imp.ScalarValue bt ept _)) = + let read_func = Var $ readFun bt ept + read_bin_func = Var $ readBinFun bt ept + type_enum = String $ readTypeEnum bt ept + bt' = compilePrimTypeExt bt ept + readScalar = initializeGenericFunction "ReadScalar" bt' + in Assign (Var $ extValueDescName decl) $ simpleCall readScalar [type_enum, read_func, read_bin_func] + +-- TODO: If the type identifier of 'Float32' is changed, currently the error +-- messages for reading binary input will not use this new name. This is also a +-- problem for the C runtime system. +readInput decl@(Imp.TransparentValue (Imp.ArrayValue _ _ _ bt ept dims)) = + let rank' = Var $ show $ length dims + type_enum = String $ readTypeEnum bt ept + bt' = compilePrimTypeExt bt ept + read_func = Var $ readFun bt ept + readArray = initializeGenericFunction "ReadArray" bt' + in Assign (Var $ extValueDescName decl) $ simpleCall readArray [rank', type_enum, read_func] + +initializeGenericFunction :: String -> String -> String +initializeGenericFunction fun tp = fun ++ "<" ++ tp ++ ">" + + +printPrimStm :: CSExp -> CSStmt +printPrimStm val = Exp $ simpleCall "WriteValue" [val] + +formatString :: String -> [CSExp] -> CSExp +formatString fmt contents = + simpleCall "String.Format" $ String fmt : contents + +printStm :: Imp.ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt +printStm Imp.ScalarValue{} _ e = + return $ printPrimStm e +printStm (Imp.ArrayValue _ _ _ _ _ []) ind e = do + let e' = Index e (IdxExp (PostUnOp "++" ind)) + return $ printPrimStm e' + +printStm (Imp.ArrayValue mem memsize space bt ept (outer:shape)) ind e = do + ptr <- newVName "shapePtr" + first <- newVName "printFirst" + let size = callMethod (CreateArray (Primitive $ CSInt Int32T) $ map compileDim $ outer:shape) + "Aggregate" [ Integer 1 + , Lambda (Tuple [Var "acc", Var "val"]) + [Exp $ BinOp "*" (Var "acc") (Var "val")] + ] + emptystr = "empty(" ++ ppArrayType bt (length shape) ++ ")" + + printelem <- printStm (Imp.ArrayValue mem memsize space bt ept shape) ind e + return $ + If (BinOp "==" size (Integer 0)) + [puts emptystr] + [ Assign (Var $ pretty first) $ Var "true" + , puts "[" + , For (pretty ptr) (compileDim outer) + [ If (simpleCall "!" [Var $ pretty first]) [puts ", "] [] + , printelem + , Reassign (Var $ pretty first) $ Var "false" + ] + , puts "]" + ] + + where ppArrayType :: PrimType -> Int -> String + ppArrayType t 0 = prettyPrimType ept t + ppArrayType t n = "[]" ++ ppArrayType t (n-1) + + prettyPrimType Imp.TypeUnsigned (IntType Int8) = "u8" + prettyPrimType Imp.TypeUnsigned (IntType Int16) = "u16" + prettyPrimType Imp.TypeUnsigned (IntType Int32) = "u32" + prettyPrimType Imp.TypeUnsigned (IntType Int64) = "u64" + prettyPrimType _ t = pretty t + + puts s = Exp $ simpleCall "Console.Write" [String s] + +printValue :: [(Imp.ExternalValue, CSExp)] -> CompilerM op s [CSStmt] +printValue = fmap concat . mapM (uncurry printValue') + -- We copy non-host arrays to the host before printing. This is + -- done in a hacky way - we assume the value has a .get()-method + -- that returns an equivalent Numpy array. This works for CSOpenCL, + -- but we will probably need yet another plugin mechanism here in + -- the future. + where printValue' (Imp.OpaqueValue desc _) _ = + return [Exp $ simpleCall "Console.Write" + [String $ "#"]] + printValue' (Imp.TransparentValue r@Imp.ScalarValue{}) e = do + p <- printStm r (Integer 0) e + return [p, Exp $ simpleCall "Console.Write" [String "\n"]] + printValue' (Imp.TransparentValue r@Imp.ArrayValue{}) e = do + tuple <- newVName "resultArr" + i <- newVName "arrInd" + let i' = Var $ compileName i + p <- printStm r i' (Var $ compileName tuple) + let e' = Var $ pretty e + return [ Assign (Var $ compileName tuple) (Field e' "Item1") + , Assign i' (Integer 0) + , p + , Exp $ simpleCall "Console.Write" [String "\n"]] + +prepareEntry :: (Name, Imp.Function op) -> CompilerM op s + (String, [(CSType, String)], CSType, [CSStmt], [CSStmt], [CSStmt], [CSStmt], + [(Imp.ExternalValue, CSExp)], [CSStmt]) +prepareEntry (fname, Imp.Function _ outputs inputs _ results args) = do + let (output_types, output_paramNames) = unzip $ map compileTypedInput outputs + funTuple = tupleOrSingle $ fmap Var output_paramNames + + + (_, sizeDecls) <- collect' $ forM args declsfunction + + (argexps_mem_copies, prepare_run) <- collect' $ forM inputs $ \case + Imp.MemParam name space -> do + -- A program might write to its input parameters, so create a new memory + -- block and copy the source there. This way the program can be run more + -- than once. + name' <- newVName $ baseString name <> "_copy" + copy <- asks envCopy + allocate <- asks envAllocate + + let size = Var (compileName name ++ "_nbytes") + dest = name' + src = name + offset = Integer 0 + case space of + DefaultSpace -> + stm $ Reassign (Var (compileName name')) + (simpleCall "allocateMem" [size]) -- FIXME + Space sid -> + allocate name' size sid + copy dest offset space src offset space size (IntType Int64) -- FIXME + return $ Just (compileName name') + _ -> return Nothing + + prepareIn <- collect $ mapM_ entryPointInput $ zip3 [0..] args $ + map (Var . extValueDescName) args + (res, prepareOut) <- collect' $ mapM entryPointOutput results + + let mem_copies = mapMaybe liftMaybe $ zip argexps_mem_copies inputs + mem_copy_inits = map initCopy mem_copies + + argexps_lib = map (compileName . Imp.paramName) inputs + argexps_bin = zipWith fromMaybe argexps_lib argexps_mem_copies + fname' = futharkFun (nameToString fname) + arg_types = map (fst . compileTypedInput) inputs + inputs' = zip arg_types (map extValueDescName args) + output_type = tupleOrSingleEntryT output_types + call_lib = [Reassign funTuple $ simpleCall fname' (fmap Var argexps_lib)] + call_bin = [Reassign funTuple $ simpleCall fname' (fmap Var argexps_bin)] + prepareIn' = prepareIn ++ mem_copy_inits ++ sizeDecls + + return (nameToString fname, inputs', output_type, + prepareIn', call_lib, call_bin, prepareOut, + zip results res, prepare_run) + + where liftMaybe (Just a, b) = Just (a,b) + liftMaybe _ = Nothing + + initCopy (varName, Imp.MemParam _ space) = declMem' varName space + initCopy _ = Pass + + valueDescFun (Imp.ArrayValue mem _ Imp.DefaultSpace _ _ _) = + stm $ Assign (Var $ compileName mem ++ "_nbytes") (Var $ compileName mem ++ ".Length") + valueDescFun (Imp.ArrayValue mem _ (Imp.Space _) bt _ dims) = + stm $ Assign (Var $ compileName mem ++ "_nbytes") $ foldr (BinOp "*" . compileDim) (sizeOf $ compilePrimTypeToAST bt) dims + valueDescFun _ = stm Pass + + declsfunction (Imp.TransparentValue v) = valueDescFun v + declsfunction (Imp.OpaqueValue _ vs) = mapM_ valueDescFun vs + +copyMemoryDefaultSpace :: VName -> CSExp -> VName -> CSExp -> CSExp -> + CompilerM op s () +copyMemoryDefaultSpace destmem destidx srcmem srcidx nbytes = + stm $ Exp $ simpleCall "Buffer.BlockCopy" [ Var (compileName srcmem), srcidx + , Var (compileName destmem), destidx, + nbytes] + +compileEntryFun :: [CSStmt] -> (Name, Imp.Function op) + -> CompilerM op s CSFunDef +compileEntryFun pre_timing entry@(_,Imp.Function _ outputs _ _ results args) = do + let params = map (getType &&& extValueDescName) args + let outputType = tupleOrSingleEntryT $ map getType results + + (fname', _, _, prepareIn, body_lib, _, prepareOut, res, _) <- prepareEntry entry + let ret = Return $ tupleOrSingleEntry $ map snd res + let outputDecls = map getDefaultDecl outputs + do_run = body_lib ++ pre_timing + (do_run_with_timing, close_runtime_file) <- addTiming do_run + + let do_warmup_run = If (Var "DoWarmupRun") do_run [] + do_num_runs = For "i" (Var "NumRuns") do_run_with_timing + + return $ Def fname' outputType params $ + prepareIn ++ outputDecls ++ [do_warmup_run, do_num_runs, close_runtime_file] ++ prepareOut ++ [ret] + + where getType :: Imp.ExternalValue -> CSType + getType (Imp.OpaqueValue _ valueDescs) = + let valueDescs' = map getType' valueDescs + in Composite $ SystemTupleT valueDescs' + getType (Imp.TransparentValue valueDesc) = + getType' valueDesc + + getType' :: Imp.ValueDesc -> CSType + getType' (Imp.ScalarValue primtype signedness _) = + compilePrimTypeToASText primtype signedness + getType' (Imp.ArrayValue _ _ _ primtype signedness _) = + let t = compilePrimTypeToASText primtype signedness + in Composite $ SystemTupleT [Composite $ ArrayT t, Composite $ ArrayT $ Primitive $ CSInt Int64T] + + +callEntryFun :: [CSStmt] -> (Name, Imp.Function op) + -> CompilerM op s (CSFunDef, String, CSExp) +callEntryFun pre_timing entry@(fname, Imp.Function _ outputs _ _ _ decl_args) = + if any isOpaque decl_args then + return (Def fname' VoidT [] [exitException], nameToString fname, Var fname') + else do + (_, _, _, prepareIn, _, body_bin, prepare_out, res, prepare_run) <- prepareEntry entry + let str_input = map readInput decl_args + + let outputDecls = map getDefaultDecl outputs + exitcall = [ + Exp $ simpleCall "Console.Error.WriteLine" [formatString "Assertion.{0} failed" [Var "e"]] + , Exp $ simpleCall "Environment.Exit" [Integer 1] + ] + except' = Catch (Var "Exception") exitcall + do_run = body_bin ++ pre_timing + (do_run_with_timing, close_runtime_file) <- addTiming do_run + + -- We ignore overflow errors and the like for executable entry + -- points. These are (somewhat) well-defined in Futhark. + + let maybe_free = + [If (BinOp "<" (Var "i") (BinOp "-" (Var "NumRuns") (Integer 1))) + prepare_out []] + + do_warmup_run = + If (Var "DoWarmupRun") (prepare_run ++ do_run ++ prepare_out) [] + + do_num_runs = + For "i" (Var "NumRuns") (prepare_run ++ do_run_with_timing ++ maybe_free) + + str_output <- printValue res + + return (Def fname' VoidT [] $ + str_input ++ prepareIn ++ outputDecls ++ + [Try [do_warmup_run, do_num_runs] [except']] ++ + [close_runtime_file] ++ + str_output, + + nameToString fname, + + Var fname') + + where fname' = "entry_" ++ nameToString fname + isOpaque Imp.TransparentValue{} = False + isOpaque _ = True + + exitException = Throw $ simpleInitClass "Exception" [String $ "The function " ++ nameToString fname ++ " is not available as an entry function."] + +addTiming :: [CSStmt] -> CompilerM s op ([CSStmt], CSStmt) +addTiming statements = do + syncFun <- asks envSyncFun + + return ([ Assign (Var "StopWatch") $ simpleInitClass "Stopwatch" [] + , syncFun + , Exp $ simpleCall "StopWatch.Start" [] ] ++ + statements ++ + [ syncFun + , Exp $ simpleCall "StopWatch.Stop" [] + , Assign (Var "timeElapsed") $ asMicroseconds (Var "StopWatch") + , If (not_null (Var "RuntimeFile")) [print_runtime] [] + ] + , If (not_null (Var "RuntimeFile")) [ + Exp $ simpleCall "RuntimeFileWriter.Close" [] , + Exp $ simpleCall "RuntimeFile.Close" [] + ] [] + ) + + where print_runtime = Exp $ simpleCall "RuntimeFileWriter.WriteLine" [ callMethod (Var "timeElapsed") "ToString" [] ] + not_null var = BinOp "!=" var Null + asMicroseconds watch = + BinOp "/" (Field watch "ElapsedTicks") + (BinOp "/" (Field (Var "TimeSpan") "TicksPerMillisecond") (Integer 1000)) + +compileUnOp :: Imp.UnOp -> String +compileUnOp op = + case op of + Not -> "!" + Complement{} -> "~" + Abs{} -> "Math.Abs" -- actually write these helpers + FAbs{} -> "Math.Abs" + SSignum{} -> "ssignum" + USignum{} -> "usignum" + +compileBinOpLike :: Monad m => + Imp.Exp -> Imp.Exp + -> CompilerM op s (CSExp, CSExp, String -> m CSExp) +compileBinOpLike x y = do + x' <- compileExp x + y' <- compileExp y + let simple s = return $ BinOp s x' y' + return (x', y', simple) + +-- | The ctypes type corresponding to a 'PrimType'. +compilePrimType :: PrimType -> String +compilePrimType t = + case t of + IntType Int8 -> "sbyte" + IntType Int16 -> "short" + IntType Int32 -> "int" + IntType Int64 -> "long" + FloatType Float32 -> "float" + FloatType Float64 -> "double" + Imp.Bool -> "bool" + Cert -> "bool" + +-- | The ctypes type corresponding to a 'PrimType', taking sign into account. +compilePrimTypeExt :: PrimType -> Imp.Signedness -> String +compilePrimTypeExt t ept = + case (t, ept) of + (IntType Int8, Imp.TypeUnsigned) -> "byte" + (IntType Int16, Imp.TypeUnsigned) -> "ushort" + (IntType Int32, Imp.TypeUnsigned) -> "uint" + (IntType Int64, Imp.TypeUnsigned) -> "ulong" + (IntType Int8, _) -> "sbyte" + (IntType Int16, _) -> "short" + (IntType Int32, _) -> "int" + (IntType Int64, _) -> "long" + (FloatType Float32, _) -> "float" + (FloatType Float64, _) -> "double" + (Imp.Bool, _) -> "bool" + (Cert, _) -> "byte" + +-- | Select function to retrieve bytes from byte array as specific data type +-- | The ctypes type corresponding to a 'PrimType'. +compileTypecastExt :: PrimType -> Imp.Signedness -> (CSExp -> CSExp) +compileTypecastExt t ept = + let t' = case (t, ept) of + (IntType Int8 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt8T + (IntType Int16 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt16T + (IntType Int32 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt32T + (IntType Int64 , Imp.TypeUnsigned)-> Primitive $ CSUInt UInt64T + (IntType Int8 , _)-> Primitive $ CSInt Int8T + (IntType Int16 , _)-> Primitive $ CSInt Int16T + (IntType Int32 , _)-> Primitive $ CSInt Int32T + (IntType Int64 , _)-> Primitive $ CSInt Int64T + (FloatType Float32, _)-> Primitive $ CSFloat FloatT + (FloatType Float64, _)-> Primitive $ CSFloat DoubleT + (Imp.Bool , _)-> Primitive BoolT + (Cert, _)-> Primitive $ CSInt Int8T + in Cast t' + +-- | The ctypes type corresponding to a 'PrimType'. +compileTypecast :: PrimType -> (CSExp -> CSExp) +compileTypecast t = + let t' = case t of + IntType Int8 -> Primitive $ CSInt Int8T + IntType Int16 -> Primitive $ CSInt Int16T + IntType Int32 -> Primitive $ CSInt Int32T + IntType Int64 -> Primitive $ CSInt Int64T + FloatType Float32 -> Primitive $ CSFloat FloatT + FloatType Float64 -> Primitive $ CSFloat DoubleT + Imp.Bool -> Primitive BoolT + Cert -> Primitive $ CSInt Int8T + in Cast t' + +-- | The ctypes type corresponding to a 'PrimType'. +compilePrimValue :: Imp.PrimValue -> CSExp +compilePrimValue (IntValue (Int8Value v)) = + Cast (Primitive $ CSInt Int8T) $ Integer $ toInteger v +compilePrimValue (IntValue (Int16Value v)) = + Cast (Primitive $ CSInt Int16T) $ Integer $ toInteger v +compilePrimValue (IntValue (Int32Value v)) = + Cast (Primitive $ CSInt Int32T) $ Integer $ toInteger v +compilePrimValue (IntValue (Int64Value v)) = + Cast (Primitive $ CSInt Int64T) $ Integer $ toInteger v +compilePrimValue (FloatValue (Float32Value v)) + | isInfinite v = + if v > 0 then Var "Single.PositiveInfinity" else Var "Single.NegativeInfinity" + | isNaN v = + Var "Single.NaN" + | otherwise = Cast (Primitive $ CSFloat FloatT) (Float $ fromRational $ toRational v) +compilePrimValue (FloatValue (Float64Value v)) + | isInfinite v = + if v > 0 then Var "Double.PositiveInfinity" else Var "Double.NegativeInfinity" + | isNaN v = + Var "Double.NaN" + | otherwise = Cast (Primitive $ CSFloat DoubleT) (Float $ fromRational $ toRational v) +compilePrimValue (BoolValue v) = Bool v +compilePrimValue Checked = Bool True + +compileExp :: Imp.Exp -> CompilerM op s CSExp + +compileExp (Imp.ValueExp v) = return $ compilePrimValue v + +compileExp (Imp.LeafExp (Imp.ScalarVar vname) _) = + return $ Var $ compileName vname + +compileExp (Imp.LeafExp (Imp.SizeOf t) _) = + return $ (compileTypecast $ IntType Int32) (Integer $ primByteSize t) + +compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) (IntType Int8) DefaultSpace _) _) = do + let src' = compileName src + iexp' <- compileExp iexp + return $ Cast (Primitive $ CSInt Int8T) (Index (Var src') (IdxExp iexp')) + +compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) bt DefaultSpace _) _) = do + iexp' <- compileExp iexp + let bt' = compilePrimType bt + return $ simpleCall ("indexArray_" ++ bt') [Var $ compileName src, iexp'] + +compileExp (Imp.LeafExp (Imp.Index src (Imp.Count iexp) restype (Imp.Space space) _) _) = + join $ asks envReadScalar + <*> pure src <*> compileExp iexp + <*> pure restype <*> pure space + +compileExp (Imp.BinOpExp op x y) = do + (x', y', simple) <- compileBinOpLike x y + case op of + FAdd{} -> simple "+" + FSub{} -> simple "-" + FMul{} -> simple "*" + FDiv{} -> simple "/" + LogAnd{} -> simple "&&" + LogOr{} -> simple "||" + _ -> return $ simpleCall (pretty op) [x', y'] + +compileExp (Imp.ConvOpExp conv x) = do + x' <- compileExp x + return $ simpleCall (pretty conv) [x'] + +compileExp (Imp.CmpOpExp cmp x y) = do + (x', y', simple) <- compileBinOpLike x y + case cmp of + CmpEq{} -> simple "==" + FCmpLt{} -> simple "<" + FCmpLe{} -> simple "<=" + _ -> return $ simpleCall (pretty cmp) [x', y'] + +compileExp (Imp.UnOpExp op exp1) = + PreUnOp (compileUnOp op) <$> compileExp exp1 + +compileExp (Imp.FunExp h args _) = + simpleCall (futharkFun (pretty h)) <$> mapM compileExp args + +compileCode :: Imp.Code op -> CompilerM op s () + +compileCode Imp.DebugPrint{} = + return () + +compileCode (Imp.Op op) = + join $ asks envOpCompiler <*> pure op + +compileCode (Imp.If cond tb fb) = do + cond' <- compileExp cond + tb' <- blockScope $ compileCode tb + fb' <- blockScope $ compileCode fb + stm $ If cond' tb' fb' + +compileCode (c1 Imp.:>>: c2) = do + compileCode c1 + compileCode c2 + +compileCode (Imp.While cond body) = do + cond' <- compileExp cond + body' <- blockScope $ compileCode body + stm $ While cond' body' + +compileCode (Imp.For i it bound body) = do + bound' <- compileExp bound + let i' = compileName i + body' <- blockScope $ compileCode body + counter <- pretty <$> newVName "counter" + one <- pretty <$> newVName "one" + stm $ Assign (Var i') $ compileTypecast (IntType it) (Integer 0) + stm $ Assign (Var one) $ compileTypecast (IntType it) (Integer 1) + stm $ For counter bound' $ body' ++ + [AssignOp "+" (Var i') (Var one)] + + +compileCode (Imp.SetScalar vname exp1) = do + let name' = Var $ compileName vname + exp1' <- compileExp exp1 + stm $ Reassign name' exp1' + +compileCode (Imp.DeclareMem v space) = declMem v space + +compileCode (Imp.DeclareScalar v Cert) = + stm $ Assign (Var $ compileName v) $ Bool True +compileCode (Imp.DeclareScalar v t) = + stm $ AssignTyped t' (Var $ compileName v) Nothing + where t' = compilePrimTypeToAST t + +compileCode (Imp.DeclareArray name DefaultSpace t vs) = + stms [Assign (Var $ "init_"++name') $ + simpleCall "unwrapArray" + [ + CreateArray (compilePrimTypeToAST t) (map compilePrimValue vs) + , simpleCall "sizeof" [Var $ compilePrimType t] + ] + , Assign (Var name') $ Var ("init_"++name') + ] + where name' = compileName name + + +compileCode (Imp.DeclareArray name (Space space) t vs) = + join $ asks envStaticArray <*> + pure name <*> pure space <*> pure t <*> pure vs + +compileCode (Imp.Comment s code) = do + code' <- blockScope $ compileCode code + stm $ Comment s code' + +compileCode (Imp.Assert e (Imp.ErrorMsg parts) (loc,locs)) = do + e' <- compileExp e + 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) + where stacktrace = intercalate " -> " (reverse $ map locStr $ loc:locs) + printFormatArg = printf "{%d}" + +compileCode (Imp.Call dests fname args) = do + args' <- mapM compileArg args + let dests' = tupleOrSingle $ fmap Var (map compileName dests) + fname' = futharkFun (pretty fname) + call' = simpleCall fname' args' + -- If the function returns nothing (is called only for side + -- effects), take care not to assign to an empty tuple. + stm $ if null dests + then Exp call' + else Reassign dests' call' + where compileArg (Imp.MemArg m) = return $ Var $ compileName m + compileArg (Imp.ExpArg e) = compileExp e + +compileCode (Imp.SetMem dest src DefaultSpace) = do + let src' = Var (compileName src) + let dest' = Var (compileName dest) + stm $ Reassign dest' src' + +compileCode (Imp.SetMem dest src _) = do + let src' = Var (compileName src) + let dest' = Var (compileName dest) + stm $ Exp $ simpleCall "MemblockSetDevice" [Ref $ Var "Ctx", Ref dest', Ref src', String (compileName src)] + +compileCode (Imp.Allocate name (Imp.Count e) DefaultSpace) = do + e' <- compileExp e + let allocate' = simpleCall "allocateMem" [e'] + let name' = Var (compileName name) + stm $ Reassign name' allocate' + +compileCode (Imp.Allocate name (Imp.Count e) (Imp.Space space)) = + join $ asks envAllocate + <*> pure name + <*> compileExp e + <*> pure space + +compileCode (Imp.Free name space) = do + unRefMem name space + tell $ mempty { accFreedMem = [name] } + +compileCode (Imp.Copy dest (Imp.Count destoffset) DefaultSpace src (Imp.Count srcoffset) DefaultSpace (Imp.Count size)) = do + destoffset' <- compileExp destoffset + srcoffset' <- compileExp srcoffset + let dest' = Var (compileName dest) + let src' = Var (compileName src) + size' <- compileExp size + stm $ Exp $ simpleCall "Buffer.BlockCopy" [src', srcoffset', dest', destoffset', size'] + +compileCode (Imp.Copy dest (Imp.Count destoffset) destspace src (Imp.Count srcoffset) srcspace (Imp.Count size)) = do + copy <- asks envCopy + join $ copy + <$> pure dest <*> compileExp destoffset <*> pure destspace + <*> pure src <*> compileExp srcoffset <*> pure srcspace + <*> compileExp size <*> pure (IntType Int64) -- FIXME + +compileCode (Imp.Write dest (Imp.Count idx) elemtype DefaultSpace _ elemexp) = do + idx' <- compileExp idx + elemexp' <- compileExp elemexp + let dest' = Var $ compileName dest + let elemtype' = compileTypecast elemtype + let ctype = elemtype' elemexp' + stm $ Exp $ simpleCall "writeScalarArray" [dest', idx', ctype] + +compileCode (Imp.Write dest (Imp.Count idx) elemtype (Imp.Space space) _ elemexp) = + join $ asks envWriteScalar + <*> pure dest + <*> compileExp idx + <*> pure elemtype + <*> pure space + <*> compileExp elemexp + +compileCode Imp.Skip = return () + +blockScope :: CompilerM op s () -> CompilerM op s [CSStmt] +blockScope = fmap snd . blockScope' + +blockScope' :: CompilerM op s a -> CompilerM op s (a, [CSStmt]) +blockScope' m = do + old_allocs <- gets compDeclaredMem + (x, items) <- pass $ do + (x, w) <- listen m + let items = accItems w + return ((x, items), const mempty) + new_allocs <- gets $ filter (`notElem` old_allocs) . compDeclaredMem + modify $ \s -> s { compDeclaredMem = old_allocs } + releases <- collect $ mapM_ (uncurry unRefMem) new_allocs + return (x, items <> releases) + +unRefMem :: VName -> Space -> CompilerM op s () +unRefMem mem (Space "device") = + (stm . Exp) $ simpleCall "MemblockUnrefDevice" [ Ref $ Var "Ctx" + , (Ref . Var . compileName) mem + , (String . compileName) mem] +unRefMem _ DefaultSpace = stm Pass +unRefMem _ (Space "local") = stm Pass +unRefMem _ (Space _) = fail "The default compiler cannot compile unRefMem for other spaces" + + +-- | Public names must have a consistent prefix. +publicName :: String -> String +publicName s = "Futhark" ++ s + +declMem :: VName -> Space -> CompilerM op s () +declMem name space = do + modify $ \s -> s { compDeclaredMem = (name, space) : compDeclaredMem s} + stm $ declMem' (compileName name) space + +declMem' :: String -> Space -> CSStmt +declMem' name DefaultSpace = + AssignTyped (Composite $ ArrayT $ Primitive ByteT) (Var name) Nothing +declMem' name (Space _) = + AssignTyped (CustomT "OpenCLMemblock") (Var name) (Just $ simpleCall "EmptyMemblock" [Var "Ctx.EMPTY_MEM_HANDLE"]) + +rawMemCSType :: Space -> CSType +rawMemCSType DefaultSpace = Composite $ ArrayT $ Primitive ByteT +rawMemCSType (Space _) = CustomT "OpenCLMemblock" + +toIntPtr :: CSExp -> CSExp +toIntPtr e = simpleInitClass "IntPtr" [e] 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 @@ -101,23 +101,26 @@ callKernel (Imp.HostCode c) = Py.compileCode c -callKernel (Imp.LaunchKernel name args kernel_size workgroup_size) = do - kernel_size' <- mapM Py.compileExp kernel_size - let total_elements = foldl mult_exp (Integer 1) kernel_size' - let cond = BinOp "!=" total_elements (Integer 0) - workgroup_size' <- Tuple <$> mapM (fmap asLong . Py.compileExp) workgroup_size - body <- Py.collect $ launchKernel name kernel_size' workgroup_size' args +callKernel (Imp.LaunchKernel name args num_workgroups workgroup_size) = do + num_workgroups' <- mapM (fmap asLong . Py.compileExp) num_workgroups + workgroup_size' <- mapM (fmap asLong . Py.compileExp) workgroup_size + let kernel_size = zipWith mult_exp num_workgroups' workgroup_size' + total_elements = foldl mult_exp (Integer 1) kernel_size + cond = BinOp "!=" total_elements (Integer 0) + body <- Py.collect $ launchKernel name kernel_size workgroup_size' args Py.stm $ If cond body [] where mult_exp = BinOp "*" -launchKernel :: String -> [PyExp] -> PyExp -> [Imp.KernelArg] -> Py.CompilerM op s () +launchKernel :: String -> [PyExp] -> [PyExp] -> [Imp.KernelArg] + -> Py.CompilerM op s () launchKernel kernel_name kernel_dims workgroup_dims args = do - let kernel_dims' = Tuple $ map asLong kernel_dims - let kernel_name' = "self." ++ kernel_name ++ "_var" + let kernel_dims' = Tuple kernel_dims + workgroup_dims' = Tuple workgroup_dims + kernel_name' = "self." ++ kernel_name ++ "_var" args' <- mapM processKernelArg args Py.stm $ Exp $ Py.simpleCall (kernel_name' ++ ".set_args") args' Py.stm $ Exp $ Py.simpleCall "cl.enqueue_nd_range_kernel" - [Var "self.queue", Var kernel_name', kernel_dims', workgroup_dims] + [Var "self.queue", Var kernel_name', kernel_dims', workgroup_dims'] finishIfSynchronous where processKernelArg :: Imp.KernelArg -> Py.CompilerM op s PyExp processKernelArg (Imp.ValueKArg e bt) = do 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 @@ -23,7 +23,7 @@ -- | Python code (as a string) that calls the -- @initiatialize_opencl_object@ procedure. Should be put in the -- class constructor. -openClInit :: [PrimType] -> String -> M.Map VName (SizeClass, Name) -> String +openClInit :: [PrimType] -> String -> M.Map Name SizeClass -> String openClInit types assign sizes = T.unpack [text| size_heuristics=$size_heuristics program = initialise_opencl_object(self, @@ -44,9 +44,9 @@ where assign' = T.pack assign size_heuristics = prettyText $ sizeHeuristicsToPython sizeHeuristicsTable types' = prettyText $ map (show . pretty) types -- Looks enough like Python. - sizes' = prettyText $ sizeClassesToPython $ M.map fst sizes + sizes' = prettyText $ sizeClassesToPython sizes -sizeClassesToPython :: M.Map VName SizeClass -> PyExp +sizeClassesToPython :: M.Map Name SizeClass -> PyExp sizeClassesToPython = Dict . map f . M.toList where f (size_name, size_class) = (String $ pretty size_name, 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 @@ -62,7 +62,6 @@ import Data.Loc import Data.Traversable import qualified Data.Set as S -import qualified Data.Semigroup as Sem import Language.Futhark.Core import Futhark.Representation.Primitive @@ -94,12 +93,11 @@ -- | A collection of imperative functions. newtype Functions a = Functions [(Name, Function a)] -instance Sem.Semigroup (Functions a) where +instance Semigroup (Functions a) where Functions x <> Functions y = Functions $ x ++ y instance Monoid (Functions a) where mempty = Functions [] - mappend = (Sem.<>) data Signedness = TypeUnsigned | TypeDirect @@ -146,7 +144,11 @@ | DeclareMem VName Space | DeclareScalar VName PrimType | DeclareArray VName Space PrimType [PrimValue] - -- ^ Create a read-only array containing the given values. + -- ^ Create an array containing the given values. The + -- lifetime of the array will be the entire application. + -- This is mostly used for constant arrays, but also for + -- some bookkeeping data, like the synchronisation + -- counts used to implement reduction. | Allocate VName (Count Bytes) Space -- ^ Memory space must match the corresponding -- 'DeclareMem'. @@ -186,14 +188,13 @@ data Volatility = Volatile | Nonvolatile deriving (Eq, Ord, Show) -instance Sem.Semigroup (Code a) where +instance Semigroup (Code a) where Skip <> y = y x <> Skip = x x <> y = x :>>: y instance Monoid (Code a) where mempty = Skip - mappend = (Sem.<>) data ExpLeaf = ScalarVar VName | SizeOf PrimType 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 @@ -12,8 +12,6 @@ , HostOp (..) , KernelOp (..) , AtomicOp (..) - , CallKernel (..) - , MapKernel (..) , Kernel (..) , LocalMemoryUse , KernelUse (..) @@ -27,7 +25,6 @@ import Control.Monad.Writer import Data.List -import qualified Data.Set as S import Futhark.CodeGen.ImpCode hiding (Function, Code) import qualified Futhark.CodeGen.ImpCode as Imp @@ -39,42 +36,24 @@ type Program = Functions HostOp type Function = Imp.Function HostOp -- | Host-level code that can call kernels. -type Code = Imp.Code CallKernel +type Code = Imp.Code HostOp -- | Code inside a kernel. type KernelCode = Imp.Code KernelOp -- | A run-time constant related to kernels. -newtype KernelConst = SizeConst VName +newtype KernelConst = SizeConst Name deriving (Eq, Ord, Show) -- | An expression whose variables are kernel constants. type KernelConstExp = PrimExp KernelConst -data HostOp = CallKernel CallKernel - | GetSize VName VName SizeClass - | CmpSizeLe VName VName SizeClass Imp.Exp +data HostOp = CallKernel Kernel + | GetSize VName Name SizeClass + | CmpSizeLe VName Name SizeClass Imp.Exp | GetSizeMax VName SizeClass deriving (Show) -data CallKernel = Map MapKernel - | AnyKernel Kernel - deriving (Show) - -- | A generic kernel containing arbitrary kernel code. -data MapKernel = MapKernel { mapKernelThreadNum :: VName - -- ^ Stm position - also serves as a unique - -- name for the kernel. - , mapKernelDesc :: String - -- ^ Used to name the kernel for readability. - , mapKernelBody :: Imp.Code KernelOp - , mapKernelUses :: [KernelUse] - , mapKernelNumGroups :: DimSize - , mapKernelGroupSize :: DimSize - , mapKernelSize :: Imp.Exp - -- ^ Do not actually execute threads past this. - } - deriving (Show) - data Kernel = Kernel { kernelBody :: Imp.Code KernelOp , kernelLocalMemory :: [LocalMemoryUse] @@ -99,7 +78,7 @@ | ConstUse VName KernelConstExp deriving (Eq, Show) -getKernels :: Program -> [CallKernel] +getKernels :: Program -> [Kernel] getKernels = nubBy sameKernel . execWriter . traverse getFunKernels where getFunKernels (CallKernel kernel) = tell [kernel] @@ -145,33 +124,17 @@ instance FreeIn HostOp where freeIn (CallKernel c) = freeIn c - freeIn (CmpSizeLe dest name _ x) = - freeIn dest <> freeIn name <> freeIn x + freeIn (CmpSizeLe dest _ _ x) = + freeIn dest <> freeIn x freeIn (GetSizeMax dest _) = freeIn dest freeIn (GetSize dest _ _) = freeIn dest -instance Pretty CallKernel where - ppr (Map k) = ppr k - ppr (AnyKernel k) = ppr k - -instance FreeIn CallKernel where - freeIn (Map k) = freeIn k - freeIn (AnyKernel k) = freeIn k - instance FreeIn Kernel where freeIn kernel = freeIn (kernelBody kernel) <> freeIn [kernelNumGroups kernel, kernelGroupSize kernel] -instance Pretty MapKernel where - ppr kernel = - text "mapKernel" <+> brace - (text "uses" <+> brace (commasep $ map ppr $ mapKernelUses kernel) - text "body" <+> brace (ppr (mapKernelThreadNum kernel) <+> - text "<- get_thread_number()" - ppr (mapKernelBody kernel))) - instance Pretty Kernel where ppr kernel = text "kernel" <+> brace @@ -187,10 +150,6 @@ ppLocalMemory (name, Right size) = ppr name <+> parens (ppr size <+> text "bytes (const)") -instance FreeIn MapKernel where - freeIn kernel = - mapKernelThreadNum kernel `S.delete` freeIn (mapKernelBody kernel) - data KernelOp = GetGroupId VName Int | GetLocalId VName Int | GetLocalSize VName Int @@ -198,7 +157,8 @@ | GetGlobalId VName Int | GetLockstepWidth VName | Atomic AtomicOp - | Barrier + | LocalBarrier + | GlobalBarrier | MemFence deriving (Show) @@ -247,8 +207,10 @@ ppr (GetLockstepWidth dest) = ppr dest <+> text "<-" <+> text "get_lockstep_width()" - ppr Barrier = - text "barrier()" + ppr LocalBarrier = + text "local_barrier()" + ppr GlobalBarrier = + text "global_barrier()" ppr MemFence = text "mem_fence()" ppr (Atomic (AtomicAdd old arr ind x)) = diff --git a/src/Futhark/CodeGen/ImpCode/OpenCL.hs b/src/Futhark/CodeGen/ImpCode/OpenCL.hs --- a/src/Futhark/CodeGen/ImpCode/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpCode/OpenCL.hs @@ -14,6 +14,7 @@ , KernelName , KernelArg (..) , OpenCL (..) + , KernelTarget (..) , module Futhark.CodeGen.ImpCode , module Futhark.Representation.Kernels.Sizes ) @@ -34,7 +35,7 @@ , openClKernelNames :: [KernelName] , openClUsedTypes :: [PrimType] -- ^ So we can detect whether the device is capable. - , openClSizes :: M.Map VName (SizeClass, Name) + , openClSizes :: M.Map Name SizeClass -- ^ Runtime-configurable constants. , hostFunctions :: Functions OpenCL } @@ -60,10 +61,15 @@ -- | Host-level OpenCL operation. data OpenCL = LaunchKernel KernelName [KernelArg] [Exp] [Exp] | HostCode Code - | GetSize VName VName - | CmpSizeLe VName VName Exp + | GetSize VName Name + | CmpSizeLe VName Name Exp | GetSizeMax VName SizeClass deriving (Show) + +-- | The target platform when compiling imperative code to a 'Program' +data KernelTarget = TargetOpenCL + | TargetCUDA + deriving (Eq) instance Pretty OpenCL where ppr = text . show 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 @@ -20,7 +20,7 @@ -- * Monadic Compiler Interface , ImpM - , Env (envDefaultSpace) + , Env (envDefaultSpace, envFunction) , VTable , getVTable , localVTable @@ -79,7 +79,7 @@ , sIf, sWhen, sUnless , sOp , sAlloc - , sArray + , sArray, sAllocArray, sStaticArray , sWrite , (<--) ) @@ -152,6 +152,7 @@ entryArrayLocation :: MemLocation , entryArrayElemType :: PrimType } + deriving (Show) entryArrayShape :: ArrayEntry -> [Imp.DimSize] entryArrayShape = memLocationShape . entryArrayLocation @@ -160,15 +161,18 @@ entryMemSize :: Imp.MemSize , entryMemSpace :: Imp.Space } + deriving (Show) newtype ScalarEntry = ScalarEntry { entryScalarType :: PrimType } + deriving (Show) -- | Every non-scalar variable must be associated with an entry. data VarEntry lore = ArrayVar (Maybe (Exp lore)) ArrayEntry | ScalarVar (Maybe (Exp lore)) ScalarEntry | MemVar (Maybe (Exp lore)) MemEntry + deriving (Show) -- | When compiling an expression, this is a description of where the -- result should end up. The integer is a reference to the construct @@ -198,16 +202,23 @@ , envCopyCompiler :: CopyCompiler lore op , envDefaultSpace :: Imp.Space , envVolatility :: Imp.Volatility + , envFakeMemory :: [Space] + -- ^ Do not actually generate allocations for these memory spaces. + , envFunction :: Name + -- ^ Name of the function we are compiling. } -newEnv :: Operations lore op -> Imp.Space -> Env lore op -newEnv ops ds = Env { envExpCompiler = opsExpCompiler ops - , envStmsCompiler = opsStmsCompiler ops - , envOpCompiler = opsOpCompiler ops - , envCopyCompiler = opsCopyCompiler ops - , envDefaultSpace = ds - , envVolatility = Imp.Nonvolatile - } +newEnv :: Operations lore op -> Imp.Space -> [Imp.Space] -> Name -> Env lore op +newEnv ops ds fake fname = + Env { envExpCompiler = opsExpCompiler ops + , envStmsCompiler = opsStmsCompiler ops + , envOpCompiler = opsOpCompiler ops + , envCopyCompiler = opsCopyCompiler ops + , envDefaultSpace = ds + , envVolatility = Imp.Nonvolatile + , envFakeMemory = fake + , envFunction = fname + } -- | The symbol table used during compilation. type VTable lore = M.Map VName (VarEntry lore) @@ -247,11 +258,10 @@ Prim $ entryScalarType scalarEntry runImpM :: ImpM lore op a - -> Operations lore op -> Imp.Space -> VNameSource - -> Either InternalError (a, VNameSource, Imp.Code op, Imp.Functions op) -runImpM (ImpM m) comp space src = do - (a, s, code) <- runRWST m (newEnv comp space) (newState src) - return (a, stateNameSource s, code, stateFunctions s) + -> Operations lore op -> Imp.Space -> [Imp.Space] -> Name -> State lore op + -> Either InternalError (a, State lore op, Imp.Code op) +runImpM (ImpM m) comp space fake fname = + runRWST m (newEnv comp space fake fname) subImpM_ :: Operations lore' op' -> ImpM lore' op' a -> ImpM lore op (Imp.Code op') @@ -311,13 +321,17 @@ in isJust $ lookup fname fs compileProg :: (ExplicitMemorish lore, MonadFreshNames m) => - Operations lore op -> Imp.Space + Operations lore op -> Imp.Space -> [Imp.Space] -> Prog lore -> m (Either InternalError (Imp.Functions op)) -compileProg ops space prog = +compileProg ops space fake prog = modifyNameSource $ \src -> - case runImpM (mapM_ compileFunDef $ progFunctions prog) ops space src of + case foldM compileFunDef' (newState src) (progFunctions prog) of Left err -> (Left err, src) - Right ((), src', _, fs) -> (Right fs, src') + Right s -> (Right $ stateFunctions s, stateNameSource s) + where compileFunDef' s fdef = do + ((), s', _) <- + runImpM (compileFunDef fdef) ops space fake (funDefName fdef) s + return s' compileInParam :: ExplicitMemorish lore => FParam lore -> ImpM lore op (Either Imp.Param ArrayDecl) @@ -1178,7 +1192,8 @@ -> ImpM lore op () compileAlloc (Pattern [] [mem]) e space = do e' <- compileSubExp e - emit $ Imp.Allocate (patElemName mem) (Imp.bytes e') space + fake <- asks $ elem space . envFakeMemory + unless fake $ emit $ Imp.Allocate (patElemName mem) (Imp.bytes e') space compileAlloc pat _ _ = compilerBugS $ "compileAlloc: Invalid pattern: " ++ pretty pat @@ -1232,7 +1247,8 @@ size_var <-- Imp.innerExp size return $ Imp.VarSize size_var emit $ Imp.DeclareMem name' space - emit $ Imp.Allocate name' size space + fake <- asks $ elem space . envFakeMemory + unless fake $ emit $ Imp.Allocate name' size space addVar name' $ MemVar Nothing $ MemEntry size' space return name' @@ -1241,6 +1257,26 @@ name' <- newVName name dArray name' bt shape membind return name' + +-- | Uses linear/iota index function. +sAllocArray :: String -> PrimType -> ShapeBase SubExp -> Space -> ImpM lore op VName +sAllocArray name pt shape space = do + let arr_bytes = Imp.bytes $ Imp.LeafExp (Imp.SizeOf pt) int32 * + product (map (compileSubExpOfType int32) (shapeDims shape)) + mem <- sAlloc (name ++ "_mem") arr_bytes space + sArray name pt shape $ + ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape + +-- | Uses linear/iota index function. +sStaticArray :: String -> Space -> PrimType -> [PrimValue] -> ImpM lore op VName +sStaticArray name space pt vs = do + let shape = Shape [constant $ length vs] + size = Imp.ConstSize $ fromIntegral (length vs) * primByteSize pt + mem <- newVName $ name ++ "_mem" + emit $ Imp.DeclareArray mem space pt vs + addVar mem $ MemVar Nothing $ MemEntry size space + sArray name pt shape $ + ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape sWrite :: VName -> [Imp.Exp] -> PrimExp Imp.ExpLeaf -> ImpM lore op () sWrite arr is v = do diff --git a/src/Futhark/CodeGen/ImpGen/CUDA.hs b/src/Futhark/CodeGen/ImpGen/CUDA.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/ImpGen/CUDA.hs @@ -0,0 +1,14 @@ +module Futhark.CodeGen.ImpGen.CUDA + ( compileProg + ) where + +import Futhark.Error +import Futhark.Representation.ExplicitMemory +import qualified Futhark.CodeGen.ImpCode.OpenCL as OpenCL +import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels +import Futhark.CodeGen.ImpGen.Kernels.ToOpenCL +import Futhark.MonadFreshNames + +compileProg :: MonadFreshNames m => Prog ExplicitMemory + -> m (Either InternalError OpenCL.Program) +compileProg prog = either Left kernelsToCUDA <$> ImpGenKernels.compileProg prog 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 @@ -1,1342 +1,497 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ConstraintKinds #-} -module Futhark.CodeGen.ImpGen.Kernels - ( compileProg - ) - where - -import Control.Arrow ((&&&)) -import Control.Monad.Except -import Control.Monad.Reader -import Data.Maybe -import Data.Semigroup ((<>)) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.List - -import Prelude hiding (quot) - -import Futhark.Error -import Futhark.MonadFreshNames -import Futhark.Transform.Rename -import Futhark.Representation.ExplicitMemory -import qualified Futhark.CodeGen.ImpCode.Kernels as Imp -import Futhark.CodeGen.ImpCode.Kernels (bytes) -import qualified Futhark.CodeGen.ImpGen as ImpGen -import Futhark.CodeGen.ImpGen ((<--), - sFor, sWhile, sComment, sIf, sWhen, sUnless, - sOp, - dPrim, dPrim_, dPrimV) -import Futhark.CodeGen.ImpGen.Kernels.Transpose -import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun -import Futhark.CodeGen.SetDefaultSpace -import Futhark.Tools (partitionChunkedKernelLambdaParameters) -import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem, IntegralExp) -import Futhark.Util (splitAt3) - -type CallKernelGen = ImpGen.ImpM ExplicitMemory Imp.HostOp -type InKernelGen = ImpGen.ImpM InKernel Imp.KernelOp - -callKernelOperations :: ImpGen.Operations ExplicitMemory Imp.HostOp -callKernelOperations = - ImpGen.Operations { ImpGen.opsExpCompiler = expCompiler - , ImpGen.opsCopyCompiler = callKernelCopy - , ImpGen.opsOpCompiler = opCompiler - , ImpGen.opsStmsCompiler = ImpGen.defCompileStms - } - -inKernelOperations :: KernelConstants -> ImpGen.Operations InKernel Imp.KernelOp -inKernelOperations constants = (ImpGen.defaultOperations $ compileInKernelOp constants) - { ImpGen.opsCopyCompiler = inKernelCopy - , ImpGen.opsExpCompiler = inKernelExpCompiler - , ImpGen.opsStmsCompiler = \_ -> compileKernelStms constants - } - -compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError Imp.Program) -compileProg prog = - fmap (setDefaultSpace (Imp.Space "device")) <$> - ImpGen.compileProg callKernelOperations (Imp.Space "device") prog - -opCompiler :: Pattern ExplicitMemory -> Op ExplicitMemory - -> CallKernelGen () -opCompiler dest (Alloc e space) = - ImpGen.compileAlloc dest e space -opCompiler dest (Inner kernel) = - kernelCompiler dest kernel - -compileInKernelOp :: KernelConstants -> Pattern InKernel -> Op InKernel - -> InKernelGen () -compileInKernelOp _ (Pattern _ [mem]) Alloc{} = - compilerLimitationS $ "Cannot allocate memory block " ++ pretty mem ++ " in kernel." -compileInKernelOp _ dest Alloc{} = - compilerBugS $ "Invalid target for in-kernel allocation: " ++ show dest -compileInKernelOp constants pat (Inner op) = - compileKernelExp constants pat op - --- | Recognise kernels (maps), give everything else back. -kernelCompiler :: Pattern ExplicitMemory -> Kernel InKernel - -> CallKernelGen () - -kernelCompiler (Pattern _ [pe]) (GetSize key size_class) = - sOp $ Imp.GetSize (patElemName pe) key size_class - -kernelCompiler (Pattern _ [pe]) (CmpSizeLe key size_class x) = - sOp . Imp.CmpSizeLe (patElemName pe) key size_class =<< ImpGen.compileSubExp x - -kernelCompiler (Pattern _ [pe]) (GetSizeMax size_class) = - sOp $ Imp.GetSizeMax (patElemName pe) size_class - -kernelCompiler pat (Kernel desc space _ kernel_body) = do - - group_size' <- ImpGen.subExpToDimSize $ spaceGroupSize space - num_threads' <- ImpGen.subExpToDimSize $ spaceNumThreads space - - let bound_in_kernel = - M.keys $ - scopeOfKernelSpace space <> - scopeOf (kernelBodyStms kernel_body) - - let global_tid = spaceGlobalId space - local_tid = spaceLocalId space - group_id = spaceGroupId space - wave_size <- newVName "wave_size" - inner_group_size <- newVName "group_size" - thread_active <- newVName "thread_active" - - let (space_is, space_dims) = unzip $ spaceDimensions space - space_dims' <- mapM ImpGen.compileSubExp space_dims - let constants = KernelConstants global_tid local_tid group_id - group_size' num_threads' - (Imp.VarSize wave_size) (zip space_is space_dims') - (Imp.var thread_active Bool) mempty - - kernel_body' <- - makeAllMemoryGlobal $ ImpGen.subImpM_ (inKernelOperations constants) $ do - dPrim_ wave_size int32 - dPrim_ inner_group_size int32 - dPrim_ thread_active Bool - ImpGen.dScope Nothing (scopeOfKernelSpace space) - - sOp (Imp.GetGlobalId global_tid 0) - sOp (Imp.GetLocalId local_tid 0) - sOp (Imp.GetLocalSize inner_group_size 0) - sOp (Imp.GetLockstepWidth wave_size) - sOp (Imp.GetGroupId group_id 0) - - setSpaceIndices space - - thread_active <-- isActive (spaceDimensions space) - - compileKernelBody pat constants kernel_body - - (uses, local_memory) <- computeKernelUses kernel_body' bound_in_kernel - - forM_ (kernelHints desc) $ \(s,v) -> do - ty <- case v of - Constant pv -> return $ Prim $ primValueType pv - Var vn -> lookupType vn - unless (primType ty) $ fail $ concat [ "debugKernelHint '", s, "'" - , " in kernel '", kernelName desc, "'" - , " did not have primType value." ] - - ImpGen.compileSubExp v >>= ImpGen.emit . Imp.DebugPrint s (elemType ty) - - sOp $ Imp.CallKernel $ Imp.AnyKernel Imp.Kernel - { Imp.kernelBody = kernel_body' - , Imp.kernelLocalMemory = local_memory - , Imp.kernelUses = uses - , Imp.kernelNumGroups = [ImpGen.compileSubExpOfType int32 $ spaceNumGroups space] - , Imp.kernelGroupSize = [ImpGen.compileSubExpOfType int32 $ spaceGroupSize space] - , Imp.kernelName = nameFromString $ kernelName desc ++ "_" ++ - show (baseTag global_tid) - } - -kernelCompiler pat e = - compilerBugS $ "ImpGen.kernelCompiler: Invalid pattern\n " ++ - pretty pat ++ "\nfor expression\n " ++ pretty e - -expCompiler :: ImpGen.ExpCompiler ExplicitMemory Imp.HostOp --- We generate a simple kernel for itoa and replicate. -expCompiler (Pattern _ [pe]) (BasicOp (Iota n x s et)) = do - destloc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe) - let tag = Just $ baseTag $ patElemName pe - thread_gid <- maybe (newVName "thread_gid") (return . VName (nameFromString "thread_gid")) tag - - makeAllMemoryGlobal $ do - (destmem, destspace, destidx) <- - ImpGen.fullyIndexArray' destloc [ImpGen.varIndex thread_gid] (IntType et) - - n' <- ImpGen.compileSubExp n - x' <- ImpGen.compileSubExp x - s' <- ImpGen.compileSubExp s - - let body = Imp.Write destmem destidx (IntType et) destspace Imp.Nonvolatile $ - Imp.ConvOpExp (SExt Int32 et) (Imp.var thread_gid int32) * s' + x' - - (group_size, num_groups) <- computeMapKernelGroups n' - - (body_uses, _) <- computeKernelUses - (freeIn body <> freeIn [n',x',s']) - [thread_gid] - - sOp $ Imp.CallKernel $ Imp.Map Imp.MapKernel - { Imp.mapKernelThreadNum = thread_gid - , Imp.mapKernelDesc = "iota" - , Imp.mapKernelNumGroups = Imp.VarSize num_groups - , Imp.mapKernelGroupSize = Imp.VarSize group_size - , Imp.mapKernelSize = n' - , Imp.mapKernelUses = body_uses - , Imp.mapKernelBody = body - } - -expCompiler - (Pattern _ [pe]) (BasicOp (Replicate (Shape ds) se)) = do - constants <- simpleKernelConstants (Just $ baseTag $ patElemName pe) "replicate" - - t <- subExpType se - let thread_gid = kernelGlobalThreadId constants - row_dims = arrayDims t - dims = ds ++ row_dims - is' = unflattenIndex (map (ImpGen.compileSubExpOfType int32) dims) $ - ImpGen.varIndex thread_gid - ds' <- mapM ImpGen.compileSubExp ds - - makeAllMemoryGlobal $ do - body <- ImpGen.subImpM_ (inKernelOperations constants) $ - ImpGen.copyDWIM (patElemName pe) is' se $ drop (length ds) is' - - dims' <- mapM ImpGen.compileSubExp dims - (group_size, num_groups) <- computeMapKernelGroups $ product dims' - - (body_uses, _) <- computeKernelUses - (freeIn body <> freeIn ds') - [thread_gid] - - sOp $ Imp.CallKernel $ Imp.Map Imp.MapKernel - { Imp.mapKernelThreadNum = thread_gid - , Imp.mapKernelDesc = "replicate" - , Imp.mapKernelNumGroups = Imp.VarSize num_groups - , Imp.mapKernelGroupSize = Imp.VarSize group_size - , Imp.mapKernelSize = product dims' - , Imp.mapKernelUses = body_uses - , Imp.mapKernelBody = body - } - --- Allocation in the "local" space is just a placeholder. -expCompiler _ (Op (Alloc _ (Space "local"))) = - return () - -expCompiler dest e = - ImpGen.defCompileExp dest e - -callKernelCopy :: ImpGen.CopyCompiler ExplicitMemory Imp.HostOp -callKernelCopy bt - destloc@(ImpGen.MemLocation destmem destshape destIxFun) - srcloc@(ImpGen.MemLocation srcmem srcshape srcIxFun) - n - | Just (destoffset, srcoffset, - num_arrays, size_x, size_y, - src_elems, dest_elems) <- isMapTransposeKernel bt destloc srcloc = do - - fname <- mapTransposeForType bt - ImpGen.emit $ Imp.Call [] fname - [Imp.MemArg destmem, Imp.ExpArg destoffset, - Imp.MemArg srcmem, Imp.ExpArg srcoffset, - Imp.ExpArg num_arrays, Imp.ExpArg size_x, Imp.ExpArg size_y, - Imp.ExpArg src_elems, Imp.ExpArg dest_elems] - - | bt_size <- primByteSize bt, - ixFunMatchesInnerShape - (Shape $ map Imp.sizeToExp destshape) destIxFun, - ixFunMatchesInnerShape - (Shape $ map Imp.sizeToExp srcshape) srcIxFun, - Just destoffset <- - IxFun.linearWithOffset destIxFun bt_size, - Just srcoffset <- - IxFun.linearWithOffset srcIxFun bt_size = do - let row_size = product $ map ImpGen.dimSizeToExp $ drop 1 srcshape - srcspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory srcmem - destspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory destmem - ImpGen.emit $ Imp.Copy - destmem (bytes destoffset) destspace - srcmem (bytes srcoffset) srcspace $ - (n * row_size) `Imp.withElemType` bt - - | otherwise = do - global_thread_index <- newVName "copy_global_thread_index" - - -- Note that the shape of the destination and the source are - -- necessarily the same. - let shape = map Imp.sizeToExp srcshape - shape_se = map (Imp.innerExp . ImpGen.dimSizeToExp) srcshape - dest_is = unflattenIndex shape_se $ ImpGen.varIndex global_thread_index - src_is = dest_is - - makeAllMemoryGlobal $ do - (_, destspace, destidx) <- ImpGen.fullyIndexArray' destloc dest_is bt - (_, srcspace, srcidx) <- ImpGen.fullyIndexArray' srcloc src_is bt - - let body = Imp.Write destmem destidx bt destspace Imp.Nonvolatile $ - Imp.index srcmem srcidx bt srcspace Imp.Nonvolatile - - let writes_to = [Imp.MemoryUse destmem] - - reads_from <- readsFromSet $ - S.singleton srcmem <> - freeIn destIxFun <> freeIn srcIxFun <> freeIn destshape - - let kernel_size = Imp.innerExp n * product (drop 1 shape) - (group_size, num_groups) <- computeMapKernelGroups kernel_size - - let bound_in_kernel = [global_thread_index] - (body_uses, _) <- computeKernelUses (kernel_size, body) bound_in_kernel - - sOp $ Imp.CallKernel $ Imp.Map Imp.MapKernel - { Imp.mapKernelThreadNum = global_thread_index - , Imp.mapKernelDesc = "copy" - , Imp.mapKernelNumGroups = Imp.VarSize num_groups - , Imp.mapKernelGroupSize = Imp.VarSize group_size - , Imp.mapKernelSize = kernel_size - , Imp.mapKernelUses = nub $ body_uses ++ writes_to ++ reads_from - , Imp.mapKernelBody = body - } - --- | We have no bulk copy operation (e.g. memmove) inside kernels, so --- turn any copy into a loop. -inKernelCopy :: ImpGen.CopyCompiler InKernel Imp.KernelOp -inKernelCopy = ImpGen.copyElementWise - -mapTransposeForType :: PrimType -> ImpGen.ImpM ExplicitMemory Imp.HostOp Name -mapTransposeForType bt = do - -- XXX: The leading underscore is to avoid clashes with a - -- programmer-defined function of the same name (this is a bad - -- solution...). - let fname = nameFromString $ "_" <> mapTransposeName bt - - exists <- ImpGen.hasFunction fname - unless exists $ ImpGen.emitFunction fname $ mapTransposeFunction bt - - return fname - -mapTransposeName :: PrimType -> String -mapTransposeName bt = "map_transpose_" ++ pretty bt - -mapTransposeFunction :: PrimType -> Imp.Function -mapTransposeFunction bt = - Imp.Function False [] params transpose_code [] [] - - where params = [memparam destmem, intparam destoffset, - memparam srcmem, intparam srcoffset, - intparam num_arrays, intparam x, intparam y, - intparam in_elems, intparam out_elems] - - space = Space "device" - memparam v = Imp.MemParam v space - intparam v = Imp.ScalarParam v $ IntType Int32 - - [destmem, destoffset, srcmem, srcoffset, - num_arrays, x, y, in_elems, out_elems, - mulx, muly, block] = - zipWith (VName . nameFromString) - ["destmem", - "destoffset", - "srcmem", - "srcoffset", - "num_arrays", - "x_elems", - "y_elems", - "in_elems", - "out_elems", - -- The following is only used for low width/height - -- transpose kernels - "mulx", - "muly", - "block" - ] - [0..] - - v32 v = Imp.var v int32 - - block_dim_int = 16 - - block_dim :: IntegralExp a => a - block_dim = 16 - - -- When an input array has either width==1 or height==1, performing a - -- transpose will be the same as performing a copy. If 'input_size' or - -- 'output_size' is not equal to width*height, then this trick will not - -- work when there are more than one array to process, as it is a per - -- array limit. We could copy each array individually, but currently we - -- do not. - can_use_copy = - let in_out_eq = CmpOpExp (CmpEq $ IntType Int32) (v32 in_elems) (v32 out_elems) - onearr = CmpOpExp (CmpEq $ IntType Int32) (v32 num_arrays) 1 - noprob_widthheight = CmpOpExp (CmpEq $ IntType Int32) - (v32 x * v32 y) - (v32 in_elems) - height_is_one = CmpOpExp (CmpEq $ IntType Int32) (v32 y) 1 - width_is_one = CmpOpExp (CmpEq $ IntType Int32) (v32 x) 1 - in BinOpExp LogAnd - in_out_eq - (BinOpExp LogAnd - (BinOpExp LogOr onearr noprob_widthheight) - (BinOpExp LogOr width_is_one height_is_one)) - - transpose_code = - Imp.If input_is_empty mempty $ mconcat - [ Imp.DeclareScalar muly (IntType Int32) - , Imp.SetScalar muly $ block_dim `quot` v32 x - , Imp.DeclareScalar mulx (IntType Int32) - , Imp.SetScalar mulx $ block_dim `quot` v32 y - , Imp.If can_use_copy copy_code $ - Imp.If should_use_lowwidth (callTransposeKernel TransposeLowWidth) $ - Imp.If should_use_lowheight (callTransposeKernel TransposeLowHeight) $ - Imp.If should_use_small (callTransposeKernel TransposeSmall) $ - callTransposeKernel TransposeNormal] - - input_is_empty = - v32 num_arrays .==. 0 .||. v32 x .==. 0 .||. v32 y .==. 0 - - should_use_small = BinOpExp LogAnd - (CmpOpExp (CmpSle Int32) (v32 x) (block_dim `quot` 2)) - (CmpOpExp (CmpSle Int32) (v32 y) (block_dim `quot` 2)) - - should_use_lowwidth = BinOpExp LogAnd - (CmpOpExp (CmpSle Int32) (v32 x) (block_dim `quot` 2)) - (CmpOpExp (CmpSlt Int32) block_dim (v32 y)) - - should_use_lowheight = BinOpExp LogAnd - (CmpOpExp (CmpSle Int32) (v32 y) (block_dim `quot` 2)) - (CmpOpExp (CmpSlt Int32) block_dim (v32 x)) - - copy_code = - let num_bytes = - v32 in_elems * Imp.LeafExp (Imp.SizeOf bt) (IntType Int32) - in Imp.Copy - destmem (Imp.Count $ v32 destoffset) space - srcmem (Imp.Count $ v32 srcoffset) space - (Imp.Count num_bytes) - - callTransposeKernel = - Imp.Op . Imp.CallKernel . Imp.AnyKernel . - mapTransposeKernel (mapTransposeName bt) block_dim_int - (destmem, v32 destoffset, srcmem, v32 srcoffset, - v32 x, v32 y, v32 in_elems, v32 out_elems, - v32 mulx, v32 muly, v32 num_arrays, - block) bt - - -inKernelExpCompiler :: ImpGen.ExpCompiler InKernel Imp.KernelOp -inKernelExpCompiler _ (BasicOp (Assert _ _ (loc, locs))) = - compilerLimitationS $ - unlines [ "Cannot compile assertion at " ++ - intercalate " -> " (reverse $ map locStr $ loc:locs) ++ - " inside parallel kernel." - , "As a workaround, surround the expression with 'unsafe'."] --- The static arrays stuff does not work inside kernels. -inKernelExpCompiler (Pattern _ [dest]) (BasicOp (ArrayLit es _)) = - forM_ (zip [0..] es) $ \(i,e) -> - ImpGen.copyDWIM (patElemName dest) [fromIntegral (i::Int32)] e [] -inKernelExpCompiler dest e = - ImpGen.defCompileExp dest e - -computeKernelUses :: FreeIn a => - a -> [VName] - -> CallKernelGen ([Imp.KernelUse], [Imp.LocalMemoryUse]) -computeKernelUses kernel_body bound_in_kernel = do - let actually_free = freeIn kernel_body `S.difference` S.fromList bound_in_kernel - - -- Compute the variables that we need to pass to the kernel. - reads_from <- readsFromSet actually_free - - -- Are we using any local memory? - local_memory <- computeLocalMemoryUse actually_free - return (nub reads_from, nub local_memory) - -readsFromSet :: Names -> CallKernelGen [Imp.KernelUse] -readsFromSet free = - fmap catMaybes $ - forM (S.toList free) $ \var -> do - t <- lookupType var - case t of - Array {} -> return Nothing - Mem _ (Space "local") -> return Nothing - Mem _ _ -> return $ Just $ Imp.MemoryUse var - Prim bt -> - isConstExp var >>= \case - Just ce -> return $ Just $ Imp.ConstUse var ce - Nothing | bt == Cert -> return Nothing - | otherwise -> return $ Just $ Imp.ScalarUse var bt - -computeLocalMemoryUse :: Names -> CallKernelGen [Imp.LocalMemoryUse] -computeLocalMemoryUse free = - fmap catMaybes $ - forM (S.toList free) $ \var -> do - t <- lookupType var - case t of - Mem memsize (Space "local") -> do - memsize' <- localMemSize =<< ImpGen.subExpToDimSize memsize - return $ Just (var, memsize') - _ -> return Nothing - -localMemSize :: Imp.MemSize -> CallKernelGen (Either Imp.MemSize Imp.KernelConstExp) -localMemSize (Imp.ConstSize x) = - return $ Right $ ValueExp $ IntValue $ Int64Value x -localMemSize (Imp.VarSize v) = isConstExp v >>= \case - Just e | isStaticExp e -> return $ Right e - _ -> return $ Left $ Imp.VarSize v - --- | Only some constant expressions quality 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 daring an array in C. -isStaticExp :: Imp.KernelConstExp -> Bool -isStaticExp LeafExp{} = True -isStaticExp ValueExp{} = True -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 - -isConstExp :: VName -> CallKernelGen (Maybe Imp.KernelConstExp) -isConstExp v = do - vtable <- ImpGen.getVTable - let lookupConstExp name = constExp =<< hasExp =<< M.lookup name vtable - constExp (Op (Inner (GetSize key _))) = Just $ LeafExp (Imp.SizeConst key) int32 - constExp e = primExpFromExp lookupConstExp e - return $ lookupConstExp v - where hasExp (ImpGen.ArrayVar e _) = e - hasExp (ImpGen.ScalarVar e _) = e - hasExp (ImpGen.MemVar e _) = e - --- | Change every memory block to be in the global address space, --- except those who are in the local memory space. This only affects --- generated code - we still need to make sure that the memory is --- actually present on the device (and dared as variables in the --- kernel). -makeAllMemoryGlobal :: CallKernelGen a -> CallKernelGen a -makeAllMemoryGlobal = - local (\env -> env { ImpGen.envDefaultSpace = Imp.Space "global" }) . - ImpGen.localVTable (M.map globalMemory) - where globalMemory (ImpGen.MemVar _ entry) - | ImpGen.entryMemSpace entry /= Space "local" = - ImpGen.MemVar Nothing entry { ImpGen.entryMemSpace = Imp.Space "global" } - globalMemory entry = - entry - -computeMapKernelGroups :: Imp.Exp -> CallKernelGen (VName, VName) -computeMapKernelGroups kernel_size = do - group_size <- dPrim "group_size" int32 - let group_size_var = Imp.var group_size int32 - sOp $ Imp.GetSize group_size group_size Imp.SizeGroup - num_groups <- dPrimV "num_groups" $ kernel_size `quotRoundingUp` Imp.ConvOpExp (SExt Int32 Int32) group_size_var - return (group_size, num_groups) - -isMapTransposeKernel :: PrimType -> ImpGen.MemLocation -> ImpGen.MemLocation - -> Maybe (Imp.Exp, Imp.Exp, - Imp.Exp, Imp.Exp, Imp.Exp, - Imp.Exp, Imp.Exp) -isMapTransposeKernel bt - (ImpGen.MemLocation _ _ destIxFun) - (ImpGen.MemLocation _ _ srcIxFun) - | Just (dest_offset, perm_and_destshape) <- IxFun.rearrangeWithOffset destIxFun bt_size, - (perm, destshape) <- unzip perm_and_destshape, - srcshape' <- IxFun.shape srcIxFun, - Just src_offset <- IxFun.linearWithOffset srcIxFun bt_size, - Just (r1, r2, _) <- isMapTranspose perm = - isOk (product srcshape') (product destshape) destshape swap r1 r2 dest_offset src_offset - | Just dest_offset <- IxFun.linearWithOffset destIxFun bt_size, - Just (src_offset, perm_and_srcshape) <- IxFun.rearrangeWithOffset srcIxFun bt_size, - (perm, srcshape) <- unzip perm_and_srcshape, - destshape' <- IxFun.shape destIxFun, - Just (r1, r2, _) <- isMapTranspose perm = - isOk (product srcshape) (product destshape') srcshape id r1 r2 dest_offset src_offset - | otherwise = - Nothing - where bt_size = primByteSize bt - swap (x,y) = (y,x) - - isOk src_elems dest_elems shape f r1 r2 dest_offset src_offset = do - let (num_arrays, size_x, size_y) = getSizes shape f r1 r2 - return (dest_offset, src_offset, - num_arrays, size_x, size_y, - src_elems, dest_elems) - - getSizes shape f r1 r2 = - let (mapped, notmapped) = splitAt r1 shape - (pretrans, posttrans) = f $ splitAt r2 notmapped - in (product mapped, product pretrans, product posttrans) - -writeParamToLocalMemory :: Typed (MemBound u) => - Imp.Exp -> (VName, t) -> Param (MemBound u) - -> ImpGen.ImpM lore op () -writeParamToLocalMemory i (mem, _) param - | Prim t <- paramType param = - ImpGen.emit $ - Imp.Write mem (bytes i') bt (Space "local") Imp.Volatile $ - Imp.var (paramName param) t - | otherwise = - return () - where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32 - bt = elemType $ paramType param - -readParamFromLocalMemory :: Typed (MemBound u) => - VName -> Imp.Exp -> Param (MemBound u) -> (VName, t) - -> ImpGen.ImpM lore op () -readParamFromLocalMemory index i param (l_mem, _) - | Prim _ <- paramType param = - paramName param <-- - Imp.index l_mem (bytes i') bt (Space "local") Imp.Volatile - | otherwise = index <-- i - where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32 - bt = elemType $ paramType param - -computeThreadChunkSize :: SplitOrdering - -> Imp.Exp - -> Imp.Count Imp.Elements - -> Imp.Count Imp.Elements - -> VName - -> ImpGen.ImpM lore op () -computeThreadChunkSize (SplitStrided stride) thread_index elements_per_thread num_elements chunk_var = do - stride' <- ImpGen.compileSubExp stride - chunk_var <-- - Imp.BinOpExp (SMin Int32) - (Imp.innerExp elements_per_thread) - ((Imp.innerExp num_elements - thread_index) `quotRoundingUp` stride') - -computeThreadChunkSize SplitContiguous thread_index elements_per_thread num_elements chunk_var = do - starting_point <- dPrimV "starting_point" $ - thread_index * Imp.innerExp elements_per_thread - remaining_elements <- dPrimV "remaining_elements" $ - Imp.innerExp num_elements - Imp.var starting_point int32 - - let no_remaining_elements = Imp.var remaining_elements int32 .<=. 0 - beyond_bounds = Imp.innerExp num_elements .<=. Imp.var starting_point int32 - - sIf (no_remaining_elements .||. beyond_bounds) - (chunk_var <-- 0) - (sIf is_last_thread - (chunk_var <-- Imp.innerExp last_thread_elements) - (chunk_var <-- Imp.innerExp elements_per_thread)) - where last_thread_elements = - num_elements - Imp.elements thread_index * elements_per_thread - is_last_thread = - Imp.innerExp num_elements .<. - (thread_index + 1) * Imp.innerExp elements_per_thread - -inBlockScan :: Imp.Exp - -> Imp.Exp - -> Imp.Exp - -> VName - -> [(VName, t)] - -> Lambda InKernel - -> InKernelGen () -inBlockScan lockstep_width block_size active local_id acc_local_mem scan_lam = ImpGen.everythingVolatile $ do - skip_threads <- dPrim "skip_threads" int32 - let in_block_thread_active = - Imp.var skip_threads int32 .<=. in_block_id - (scan_lam_i, other_index_param, actual_params) = - partitionChunkedKernelLambdaParameters $ lambdaParams scan_lam - (x_params, y_params) = - splitAt (length actual_params `div` 2) actual_params - read_operands = - zipWithM_ (readParamFromLocalMemory (paramName other_index_param) $ - Imp.var local_id int32 - Imp.var skip_threads int32) - x_params acc_local_mem - - -- Set initial y values - sWhen active $ - zipWithM_ (readParamFromLocalMemory scan_lam_i $ Imp.var local_id int32) - y_params acc_local_mem - - let op_to_y = ImpGen.compileBody' y_params $ lambdaBody scan_lam - write_operation_result = - zipWithM_ (writeParamToLocalMemory $ Imp.var local_id int32) - acc_local_mem y_params - maybeBarrier = sWhen (lockstep_width .<=. Imp.var skip_threads int32) $ - sOp Imp.Barrier - - sComment "in-block scan (hopefully no barriers needed)" $ do - skip_threads <-- 1 - sWhile (Imp.var skip_threads int32 .<. block_size) $ do - sWhen (in_block_thread_active .&&. active) $ do - sComment "read operands" read_operands - sComment "perform operation" op_to_y - - maybeBarrier - - sWhen (in_block_thread_active .&&. active) $ - sComment "write result" write_operation_result - - maybeBarrier - - skip_threads <-- Imp.var skip_threads int32 * 2 - - where block_id = Imp.var local_id int32 `quot` block_size - in_block_id = Imp.var local_id int32 - block_id * block_size - -data KernelConstants = KernelConstants - { kernelGlobalThreadId :: VName - , kernelLocalThreadId :: VName - , kernelGroupId :: VName - , kernelGroupSize :: Imp.DimSize - , _kernelNumThreads :: Imp.DimSize - , kernelWaveSize :: Imp.DimSize - , kernelDimensions :: [(VName, Imp.Exp)] - , kernelThreadActive :: Imp.Exp - , kernelStreamed :: [(VName, Imp.DimSize)] - -- ^ Chunk sizez and their maximum size. Hint - -- for unrolling. - } - --- FIXME: wing a KernelConstants structure for use in Replicate --- compilation. This cannot be the best way to do this... -simpleKernelConstants :: MonadFreshNames m => - Maybe Int -> String - -> m KernelConstants -simpleKernelConstants tag desc = do - thread_gtid <- maybe (newVName $ desc ++ "_gtid") - (return . VName (nameFromString $ desc ++ "_gtid")) tag - thread_ltid <- newVName $ desc ++ "_ltid" - thread_gid <- newVName $ desc ++ "_gid" - return $ KernelConstants - thread_gtid thread_ltid thread_gid - (Imp.ConstSize 0) (Imp.ConstSize 0) (Imp.ConstSize 0) - [] (Imp.ValueExp $ BoolValue True) mempty - -compileKernelBody :: Pattern InKernel - -> KernelConstants - -> KernelBody InKernel - -> InKernelGen () -compileKernelBody pat constants kbody = - compileKernelStms constants (stmsToList $ kernelBodyStms kbody) $ - zipWithM_ (compileKernelResult constants) (patternElements pat) $ - kernelBodyResult kbody - -compileKernelStms :: KernelConstants -> [Stm InKernel] - -> InKernelGen a - -> InKernelGen a -compileKernelStms constants ungrouped_bnds m = - compileGroupedKernelStms' $ groupStmsByGuard constants ungrouped_bnds - where compileGroupedKernelStms' [] = m - compileGroupedKernelStms' ((g, bnds):rest_bnds) = do - ImpGen.dScopes (map ((Just . stmExp) &&& (castScope . scopeOf)) bnds) - protect g $ mapM_ compileKernelStm bnds - compileGroupedKernelStms' rest_bnds - - protect Nothing body_m = - body_m - protect (Just (Imp.ValueExp (BoolValue True))) body_m = - body_m - protect (Just g) body_m = - sWhen g $ allThreads constants body_m - - compileKernelStm (Let pat _ e) = ImpGen.compileExp pat e - -groupStmsByGuard :: KernelConstants - -> [Stm InKernel] - -> [(Maybe Imp.Exp, [Stm InKernel])] -groupStmsByGuard constants bnds = - map collapse $ groupBy sameGuard $ zip (map bindingGuard bnds) bnds - where bindingGuard (Let _ _ Op{}) = Nothing - bindingGuard _ = Just $ kernelThreadActive constants - - sameGuard (g1, _) (g2, _) = g1 == g2 - - collapse [] = - (Nothing, []) - collapse l@((g,_):_) = - (g, map snd l) - -compileKernelExp :: KernelConstants -> Pattern InKernel -> KernelExp InKernel - -> InKernelGen () - -compileKernelExp _ pat (Barrier ses) = do - forM_ (zip (patternNames pat) ses) $ \(d, se) -> - ImpGen.copyDWIM d [] se [] - sOp Imp.Barrier - -compileKernelExp _ (Pattern [] [size]) (SplitSpace o w i elems_per_thread) = do - num_elements <- Imp.elements <$> ImpGen.compileSubExp w - i' <- ImpGen.compileSubExp i - elems_per_thread' <- Imp.elements <$> ImpGen.compileSubExp elems_per_thread - computeThreadChunkSize o i' elems_per_thread' num_elements (patElemName size) - -compileKernelExp constants pat (Combine (CombineSpace scatter cspace) _ aspace body) = do - -- First we compute how many times we have to iterate to cover - -- cspace with our group size. It is a fairly common case that - -- we statically know that this requires 1 iteration, so we - -- could detect it and not generate a loop in that case. - -- However, it seems to have no impact on performance (an extra - -- conditional jump), so for simplicity we just always generate - -- the loop. - let cspace_dims = map (streamBounded . snd) cspace - num_iters - | cspace_dims == [Imp.sizeToExp $ kernelGroupSize constants] = 1 - | otherwise = product cspace_dims `quotRoundingUp` - Imp.sizeToExp (kernelGroupSize constants) - - iter <- newVName "comb_iter" - - sFor iter Int32 num_iters $ do - mapM_ ((`dPrim_` int32) . fst) cspace - -- Compute the *flat* array index. - cid <- dPrimV "flat_comb_id" $ - Imp.var iter int32 * Imp.sizeToExp (kernelGroupSize constants) + - Imp.var (kernelLocalThreadId constants) int32 - - -- Turn it into a nested array index. - zipWithM_ (<--) (map fst cspace) $ unflattenIndex cspace_dims (Imp.var cid int32) - - -- Construct the body. This is mostly about the book-keeping - -- for the scatter-like part. - let (scatter_ws, scatter_ns, _scatter_vs) = unzip3 scatter - scatter_ws_repl = concat $ zipWith replicate scatter_ns scatter_ws - (scatter_pes, normal_pes) = - splitAt (sum scatter_ns) $ patternElements pat - (res_is, res_vs, res_normal) = - splitAt3 (sum scatter_ns) (sum scatter_ns) $ bodyResult body - - -- Execute the body if we are within bounds. - sWhen (isActive cspace .&&. isActive aspace) $ allThreads constants $ - ImpGen.compileStms (freeIn $ bodyResult body) (stmsToList $ bodyStms body) $ do - - forM_ (zip4 scatter_ws_repl res_is res_vs scatter_pes) $ - \(w, res_i, res_v, scatter_pe) -> do - let res_i' = ImpGen.compileSubExpOfType int32 res_i - w' = ImpGen.compileSubExpOfType int32 w - -- We have to check that 'res_i' is in-bounds wrt. an array of size 'w'. - in_bounds = 0 .<=. res_i' .&&. res_i' .<. w' - sWhen in_bounds $ ImpGen.copyDWIM (patElemName scatter_pe) [res_i'] res_v [] - - forM_ (zip normal_pes res_normal) $ \(pe, res) -> - ImpGen.copyDWIM (patElemName pe) local_index res [] - - sOp Imp.Barrier - - where streamBounded (Var v) - | Just x <- lookup v $ kernelStreamed constants = - Imp.sizeToExp x - streamBounded se = ImpGen.compileSubExpOfType int32 se - - local_index = map (ImpGen.compileSubExpOfType int32 . Var . fst) cspace - -compileKernelExp constants (Pattern _ dests) (GroupReduce w lam input) = do - groupReduce constants w lam $ map snd input - let (reduce_acc_params, _) = - splitAt (length input) $ drop 2 $ lambdaParams lam - forM_ (zip dests reduce_acc_params) $ \(dest, reduce_acc_param) -> - ImpGen.copyDWIM (patElemName dest) [] (Var $ paramName reduce_acc_param) [] - -compileKernelExp constants _ (GroupScan w lam input) = do - renamed_lam <- renameLambda lam - w' <- ImpGen.compileSubExp w - - when (any (not . primType . paramType) $ lambdaParams lam) $ - compilerLimitationS "Cannot compile parallel scans with array element type." - - let local_tid = kernelLocalThreadId constants - (_nes, arrs) = unzip input - (lam_i, other_index_param, actual_params) = - partitionChunkedKernelLambdaParameters $ lambdaParams lam - (x_params, y_params) = - splitAt (length input) actual_params - - ImpGen.dLParams (lambdaParams lam++lambdaParams renamed_lam) - lam_i <-- Imp.var local_tid int32 - - acc_local_mem <- flip zip (repeat ()) <$> - mapM (fmap (ImpGen.memLocationName . ImpGen.entryArrayLocation) . - ImpGen.lookupArray) arrs - - -- The scan works by splitting the group into blocks, which are - -- scanned separately. Typically, these blocks are smaller than - -- the lockstep width, which enables barrier-free execution inside - -- them. - -- - -- We hardcode the block size here. The only requirement is that - -- it should not be less than the square root of the group size. - -- With 32, we will work on groups of size 1024 or smaller, which - -- fits every device Troels has seen. Still, it would be nicer if - -- it were a runtime parameter. Some day. - let block_size = Imp.ValueExp $ IntValue $ Int32Value 32 - simd_width = Imp.sizeToExp $ kernelWaveSize constants - block_id = Imp.var local_tid int32 `quot` block_size - in_block_id = Imp.var local_tid int32 - block_id * block_size - doInBlockScan active = inBlockScan simd_width block_size active local_tid acc_local_mem - lid_in_bounds = Imp.var local_tid int32 .<. w' - - doInBlockScan lid_in_bounds lam - sOp Imp.Barrier - - let last_in_block = in_block_id .==. block_size - 1 - sComment "last thread of block 'i' writes its result to offset 'i'" $ - sWhen (last_in_block .&&. lid_in_bounds) $ - zipWithM_ (writeParamToLocalMemory block_id) acc_local_mem y_params - - sOp Imp.Barrier - - let is_first_block = block_id .==. 0 - ImpGen.comment - "scan the first block, after which offset 'i' contains carry-in for warp 'i+1'" $ - doInBlockScan (is_first_block .&&. lid_in_bounds) renamed_lam - - sOp Imp.Barrier - - let read_carry_in = - zipWithM_ (readParamFromLocalMemory - (paramName other_index_param) (block_id - 1)) - x_params acc_local_mem - - let op_to_y = - ImpGen.compileBody' y_params $ lambdaBody lam - write_final_result = - zipWithM_ (writeParamToLocalMemory $ Imp.var local_tid int32) acc_local_mem y_params - - sComment "carry-in for every block except the first" $ - sUnless (is_first_block .||. Imp.UnOpExp Not lid_in_bounds) $ do - sComment "read operands" read_carry_in - sComment "perform operation" op_to_y - sComment "write final result" write_final_result - - sOp Imp.Barrier - - sComment "restore correct values for first block" $ - sWhen is_first_block write_final_result - -compileKernelExp constants (Pattern _ final) (GroupStream w maxchunk lam accs _arrs) = do - let GroupStreamLambda block_size block_offset acc_params arr_params body = lam - block_offset' = Imp.var block_offset int32 - w' <- ImpGen.compileSubExp w - max_block_size <- ImpGen.compileSubExp maxchunk - - ImpGen.dLParams (acc_params++arr_params) - zipWithM_ ImpGen.compileSubExpTo (map paramName acc_params) accs - dPrim_ block_size int32 - - -- If the GroupStream is morally just a do-loop, generate simpler code. - case mapM isSimpleThreadInSpace $ stmsToList $ bodyStms body of - Just stms' | ValueExp x <- max_block_size, oneIsh x -> do - let body' = body { bodyStms = stmsFromList stms' } - body'' = allThreads constants $ - ImpGen.compileLoopBody (map paramName acc_params) body' - block_size <-- 1 - - -- Check if loop is candidate for unrolling. - let loop = - case w of - Var w_var | Just w_bound <- lookup w_var $ kernelStreamed constants, - w_bound /= Imp.ConstSize 1 -> - -- Candidate for unrolling, so generate two loops. - sIf (w' .==. Imp.sizeToExp w_bound) - (sFor block_offset Int32 (Imp.sizeToExp w_bound) body'') - (sFor block_offset Int32 w' body'') - _ -> sFor block_offset Int32 w' body'' - - if kernelThreadActive constants == Imp.ValueExp (BoolValue True) - then loop - else sWhen (kernelThreadActive constants) loop - - _ -> do - dPrim_ block_offset int32 - let body' = streaming constants block_size maxchunk $ - ImpGen.compileBody' acc_params body - - block_offset <-- 0 - - let not_at_end = block_offset' .<. w' - set_block_size = - sIf (w' - block_offset' .<. max_block_size) - (block_size <-- (w' - block_offset')) - (block_size <-- max_block_size) - increase_offset = - block_offset <-- block_offset' + max_block_size - - -- Three cases to consider for simpler generated code based - -- on max block size: (0) if full input size, do not - -- generate a loop; (1) if one, generate for-loop (2) - -- otherwise, generate chunked while-loop. - if max_block_size == w' then - (block_size <-- w') >> body' - else if max_block_size == Imp.ValueExp (value (1::Int32)) then do - block_size <-- w' - sFor block_offset Int32 w' body' - else - sWhile not_at_end $ - set_block_size >> body' >> increase_offset - - forM_ (zip final acc_params) $ \(pe, p) -> - ImpGen.copyDWIM (patElemName pe) [] (Var $ paramName p) [] - - where isSimpleThreadInSpace (Let _ _ Op{}) = Nothing - isSimpleThreadInSpace bnd = Just bnd - -compileKernelExp _ _ (GroupGenReduce w arrs op bucket values locks) = do - -- Check if bucket is in-bounds - bucket' <- mapM ImpGen.compileSubExp bucket - w' <- mapM ImpGen.compileSubExp w - sWhen (indexInBounds bucket' w') $ - atomicUpdate arrs bucket op values locking - where indexInBounds inds bounds = - foldl1 (.&&.) $ zipWith checkBound inds bounds - where checkBound ind bound = 0 .<=. ind .&&. ind .<. bound - locking = Locking locks 0 1 0 - -compileKernelExp _ dest e = - compilerBugS $ unlines ["Invalid target", " " ++ show dest, - "for kernel expression", " " ++ pretty e] - --- | Locking strategy used for an atomic update. -data Locking = Locking { lockingArray :: VName -- ^ Array containing the lock. - , lockingIsUnlocked :: Imp.Exp -- ^ Value for us to consider the lock free. - , lockingToLock :: Imp.Exp -- ^ What to write when we lock it. - , lockingToUnlock :: Imp.Exp -- ^ What to write when we unlock it. - } - -groupReduce :: ExplicitMemorish lore => - KernelConstants - -> SubExp - -> Lambda lore - -> [VName] - -> ImpGen.ImpM lore Imp.KernelOp () -groupReduce constants w lam arrs = do - w' <- ImpGen.compileSubExp w - - let local_tid = kernelLocalThreadId constants - (reduce_i, reduce_j_param, actual_reduce_params) = - partitionChunkedKernelLambdaParameters $ lambdaParams lam - (reduce_acc_params, reduce_arr_params) = - splitAt (length arrs) actual_reduce_params - reduce_j = paramName reduce_j_param - - offset <- dPrim "offset" int32 - - skip_waves <- dPrim "skip_waves" int32 - ImpGen.dLParams $ lambdaParams lam - - reduce_i <-- Imp.var local_tid int32 - - let setOffset x = do - offset <-- x - reduce_j <-- Imp.var local_tid int32 + Imp.var offset int32 - - setOffset 0 - - sWhen (Imp.var local_tid int32 .<. w') $ - zipWithM_ (readReduceArgument offset) reduce_acc_params arrs - - let read_reduce_args = zipWithM_ (readReduceArgument offset) - reduce_arr_params arrs - do_reduce = do ImpGen.comment "read array element" read_reduce_args - ImpGen.compileBody' reduce_acc_params $ lambdaBody lam - zipWithM_ (writeReduceOpResult local_tid) - reduce_acc_params arrs - in_wave_reduce = ImpGen.everythingVolatile do_reduce - - wave_size = Imp.sizeToExp $ kernelWaveSize constants - group_size = Imp.sizeToExp $ kernelGroupSize constants - wave_id = Imp.var local_tid int32 `quot` wave_size - in_wave_id = Imp.var local_tid int32 - wave_id * wave_size - num_waves = (group_size + wave_size - 1) `quot` wave_size - arg_in_bounds = Imp.var reduce_j int32 .<. w' - - doing_in_wave_reductions = - Imp.var offset int32 .<. wave_size - apply_in_in_wave_iteration = - (in_wave_id .&. (2 * Imp.var offset int32 - 1)) .==. 0 - in_wave_reductions = do - setOffset 1 - sWhile doing_in_wave_reductions $ do - sWhen (arg_in_bounds .&&. apply_in_in_wave_iteration) - in_wave_reduce - setOffset $ Imp.var offset int32 * 2 - - doing_cross_wave_reductions = - Imp.var skip_waves int32 .<. num_waves - is_first_thread_in_wave = - in_wave_id .==. 0 - wave_not_skipped = - (wave_id .&. (2 * Imp.var skip_waves int32 - 1)) .==. 0 - apply_in_cross_wave_iteration = - arg_in_bounds .&&. is_first_thread_in_wave .&&. wave_not_skipped - cross_wave_reductions = do - skip_waves <-- 1 - sWhile doing_cross_wave_reductions $ do - sOp Imp.Barrier - setOffset (Imp.var skip_waves int32 * wave_size) - sWhen apply_in_cross_wave_iteration - do_reduce - skip_waves <-- Imp.var skip_waves int32 * 2 - - in_wave_reductions - cross_wave_reductions - where readReduceArgument offset param arr - | Prim _ <- paramType param = - ImpGen.copyDWIM (paramName param) [] (Var arr) [i] - | otherwise = - return () - where i = ImpGen.varIndex (kernelLocalThreadId constants) + ImpGen.varIndex offset - - writeReduceOpResult i param arr - | Prim _ <- paramType param = - ImpGen.copyDWIM arr [ImpGen.varIndex i] (Var $ paramName param) [] - | otherwise = - return () - -atomicUpdate :: ExplicitMemorish lore => - [VName] -> [SubExp] -> Lambda lore -> [SubExp] -> Locking - -> ImpGen.ImpM lore Imp.KernelOp () -atomicUpdate [a] bucket op [v] _ - | [Prim t] <- lambdaReturnType op, - primBitSize t == 32 = do - -- If we have only one array and one non-array value (this is a - -- one-to-one correspondance) then we need only one - -- update. If operator has an atomic implementation we use - -- that, otherwise it is still a binary operator which can - -- be implemented by atomic compare-and-swap if 32 bits. - - -- Common variables. - old <- dPrim "old" t - bucket' <- mapM ImpGen.compileSubExp bucket - - (arr', _a_space, bucket_offset) <- ImpGen.fullyIndexArray a bucket' - - val' <- ImpGen.compileSubExp v - case opHasAtomicSupport old arr' bucket_offset op of - Just f -> sOp $ f val' - - Nothing -> do - -- Code generation target: - -- - -- old = d_his[idx]; - -- do { - -- assumed = old; - -- tmp = OP::apply(val, assumed); - -- old = atomicCAS(&d_his[idx], assumed, tmp); - -- } while(assumed != old); - assumed <- dPrim "assumed" t - run_loop <- dPrimV "run_loop" true - ImpGen.copyDWIM old [] (Var a) bucket' - - -- Preparing parameters - let (acc_p:arr_p:_) = lambdaParams op - - -- Critical section - ImpGen.dLParams $ lambdaParams op - - -- While-loop: Try to insert your value - let (toBits, fromBits) = - case t of FloatType Float32 -> (\x -> Imp.FunExp "to_bits32" [x] int32, - \x -> Imp.FunExp "from_bits32" [x] t) - _ -> (id, id) - sWhile (Imp.var run_loop Bool) $ do - assumed <-- Imp.var old t - paramName acc_p <-- val' - paramName arr_p <-- Imp.var assumed t - ImpGen.compileBody' [acc_p] $ lambdaBody op - old_bits <- dPrim "old_bits" int32 - sOp $ Imp.Atomic $ - Imp.AtomicCmpXchg old_bits arr' bucket_offset - (toBits (Imp.var assumed int32)) (toBits (Imp.var (paramName acc_p) int32)) - old <-- fromBits (Imp.var old_bits int32) - sWhen (toBits (Imp.var assumed t) .==. Imp.var old_bits int32) - (run_loop <-- false) - where opHasAtomicSupport old arr' bucket' lam = do - let atomic f = Imp.Atomic . f old arr' bucket' - [BasicOp (BinOp bop _ _)] <- - Just $ map stmExp $ stmsToList $ bodyStms $ lambdaBody lam - atomic <$> Imp.atomicBinOp bop - -atomicUpdate arrs bucket op values locking = do - old <- dPrim "old" int32 - loop_done <- dPrimV "loop_done" 0 - - -- Check if bucket is in-bounds - bucket' <- mapM ImpGen.compileSubExp bucket - - -- Correctly index into locks. - (locks', _locks_space, locks_offset) <- - ImpGen.fullyIndexArray (lockingArray locking) bucket' - - -- Preparing parameters - let (acc_params, arr_params) = - splitAt (length values) $ lambdaParams op - - -- Critical section - let try_acquire_lock = - sOp $ Imp.Atomic $ - Imp.AtomicCmpXchg old locks' locks_offset (lockingIsUnlocked locking) (lockingToLock locking) - lock_acquired = Imp.var old int32 .==. lockingIsUnlocked locking - loop_cond = Imp.var loop_done int32 .==. 0 - release_lock = ImpGen.everythingVolatile $ - ImpGen.sWrite (lockingArray locking) bucket' $ lockingToUnlock locking - break_loop = loop_done <-- 1 - - -- We copy the current value and the new value to the parameters - -- unless they are array-typed. If they are arrays, then the - -- index functions should already be set up correctly, so there is - -- nothing more to do. - let bind_acc_params = - forM_ (zip acc_params arrs) $ \(acc_p, arr) -> - when (primType (paramType acc_p)) $ - ImpGen.copyDWIM (paramName acc_p) [] (Var arr) bucket' - - let bind_arr_params = - forM_ (zip arr_params values) $ \(arr_p, val) -> - when (primType (paramType arr_p)) $ - ImpGen.copyDWIM (paramName arr_p) [] val [] - - let op_body = ImpGen.compileBody' acc_params $ lambdaBody op - - do_gen_reduce = zipWithM_ (writeArray bucket') arrs $ map (Var . paramName) acc_params - - -- While-loop: Try to insert your value - sWhile loop_cond $ do - try_acquire_lock - sWhen lock_acquired $ do - ImpGen.dLParams $ lambdaParams op - bind_acc_params - bind_arr_params - op_body - do_gen_reduce - release_lock - break_loop - sOp Imp.MemFence - where writeArray bucket' arr val = - ImpGen.copyDWIM arr bucket' val [] - -allThreads :: KernelConstants -> InKernelGen () -> InKernelGen () -allThreads constants = ImpGen.emit <=< ImpGen.subImpM_ (inKernelOperations constants') - where constants' = - constants { kernelThreadActive = Imp.ValueExp (BoolValue True) } - -streaming :: KernelConstants -> VName -> SubExp -> InKernelGen () -> InKernelGen () -streaming constants chunksize bound m = do - bound' <- ImpGen.subExpToDimSize bound - let constants' = - constants { kernelStreamed = (chunksize, bound') : kernelStreamed constants } - ImpGen.emit =<< ImpGen.subImpM_ (inKernelOperations constants') m - -compileKernelResult :: KernelConstants -> PatElem InKernel -> KernelResult - -> InKernelGen () - -compileKernelResult constants pe (ThreadsReturn OneResultPerGroup what) = do - i <- newVName "i" - - in_local_memory <- arrayInLocalMemory what - let me = Imp.var (kernelLocalThreadId constants) int32 - - if not in_local_memory then do - who' <- ImpGen.compileSubExp $ intConst Int32 0 - sWhen (me .==. who') $ - ImpGen.copyDWIM (patElemName pe) [ImpGen.varIndex $ kernelGroupId constants] what [] - else do - -- If the result of the group is an array in local memory, we - -- store it by collective copying among all the threads of the - -- group. TODO: also do this if the array is in global memory - -- (but this is a bit more tricky, synchronisation-wise). - -- - -- We do the reads/writes multidimensionally, but the loop is - -- single-dimensional. - ws <- mapM ImpGen.compileSubExp . arrayDims =<< subExpType what - -- Compute how many elements this thread is responsible for. - -- Formula: (w - ltid) / group_size (rounded up). - let w = product ws - ltid = ImpGen.varIndex (kernelLocalThreadId constants) - group_size = Imp.sizeToExp (kernelGroupSize constants) - to_write = (w - ltid) `quotRoundingUp` group_size - is = unflattenIndex ws $ ImpGen.varIndex i * group_size + ltid - - sFor i Int32 to_write $ - ImpGen.copyDWIM (patElemName pe) (ImpGen.varIndex (kernelGroupId constants) : is) what is - -compileKernelResult constants pe (ThreadsReturn AllThreads what) = - ImpGen.copyDWIM (patElemName pe) [ImpGen.varIndex $ kernelGlobalThreadId constants] what [] - -compileKernelResult constants pe (ThreadsReturn (ThreadsPerGroup limit) what) = - sWhen (isActive limit) $ - ImpGen.copyDWIM (patElemName pe) [ImpGen.varIndex $ kernelGroupId constants] what [] - -compileKernelResult constants pe (ThreadsReturn ThreadsInSpace what) = do - let is = map (ImpGen.varIndex . fst) $ kernelDimensions constants - sWhen (kernelThreadActive constants) $ ImpGen.copyDWIM (patElemName pe) is what [] - -compileKernelResult constants pe (ConcatReturns SplitContiguous _ per_thread_elems moffset what) = do - dest_loc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe) - let dest_loc_offset = ImpGen.offsetArray dest_loc offset - dest' = ImpGen.arrayDestination dest_loc_offset - ImpGen.copyDWIMDest dest' [] (Var what) [] - where offset = case moffset of - Nothing -> ImpGen.compileSubExpOfType int32 per_thread_elems * - ImpGen.varIndex (kernelGlobalThreadId constants) - Just se -> ImpGen.compileSubExpOfType int32 se - -compileKernelResult constants pe (ConcatReturns (SplitStrided stride) _ _ moffset what) = do - dest_loc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe) - let dest_loc' = ImpGen.strideArray - (ImpGen.offsetArray dest_loc offset) $ - ImpGen.compileSubExpOfType int32 stride - dest' = ImpGen.arrayDestination dest_loc' - ImpGen.copyDWIMDest dest' [] (Var what) [] - where offset = case moffset of - Nothing -> ImpGen.varIndex (kernelGlobalThreadId constants) - Just se -> ImpGen.compileSubExpOfType int32 se - -compileKernelResult constants pe (WriteReturn rws _arr dests) = do - rws' <- mapM ImpGen.compileSubExp rws - forM_ dests $ \(is, e) -> do - is' <- mapM ImpGen.compileSubExp is - let condInBounds i rw = 0 .<=. i .&&. i .<. rw - write = foldl (.&&.) (kernelThreadActive constants) $ - zipWith condInBounds is' rws' - sWhen write $ ImpGen.copyDWIM (patElemName pe) (map (ImpGen.compileSubExpOfType int32) is) e [] - -compileKernelResult _ _ KernelInPlaceReturn{} = - -- Already in its place... said it was a hack. - return () - -isActive :: [(VName, SubExp)] -> Imp.Exp -isActive limit = case actives of - [] -> Imp.ValueExp $ BoolValue True - x:xs -> foldl (.&&.) x xs - where (is, ws) = unzip limit - actives = zipWith active is $ map (ImpGen.compileSubExpOfType Bool) ws - active i = (Imp.var i int32 .<.) - -setSpaceIndices :: KernelSpace -> InKernelGen () -setSpaceIndices space = - case spaceStructure space of - FlatThreadSpace is_and_dims -> - flatSpaceWith gtid is_and_dims - NestedThreadSpace is_and_dims -> do - let (gtids, gdims, ltids, ldims) = unzip4 is_and_dims - gdims' <- mapM ImpGen.compileSubExp gdims - ldims' <- mapM ImpGen.compileSubExp ldims - let (gtid_es, ltid_es) = unzip $ unflattenNestedIndex gdims' ldims' gtid - zipWithM_ (<--) gtids gtid_es - zipWithM_ (<--) ltids ltid_es - where gtid = Imp.var (spaceGlobalId space) int32 - - flatSpaceWith base is_and_dims = do - let (is, dims) = unzip is_and_dims - dims' <- mapM ImpGen.compileSubExp dims - let index_expressions = unflattenIndex dims' base - zipWithM_ (<--) is index_expressions - -unflattenNestedIndex :: IntegralExp num => [num] -> [num] -> num -> [(num,num)] -unflattenNestedIndex global_dims group_dims global_id = - zip global_is local_is - where num_groups_dims = zipWith quotRoundingUp global_dims group_dims - group_size = product group_dims - group_id = global_id `Futhark.Util.IntegralExp.quot` group_size - local_id = global_id `Futhark.Util.IntegralExp.rem` group_size - - group_is = unflattenIndex num_groups_dims group_id - local_is = unflattenIndex group_dims local_id - global_is = zipWith (+) local_is $ zipWith (*) group_is group_dims +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +module Futhark.CodeGen.ImpGen.Kernels + ( compileProg + ) + where + +import Control.Monad.Except +import Control.Monad.Reader +import Data.Maybe +import qualified Data.Map.Strict as M +import Data.List + +import Prelude hiding (quot) + +import Futhark.Error +import Futhark.MonadFreshNames +import Futhark.Representation.ExplicitMemory +import qualified Futhark.CodeGen.ImpCode.Kernels as Imp +import Futhark.CodeGen.ImpCode.Kernels (bytes) +import qualified Futhark.CodeGen.ImpGen as ImpGen +import Futhark.CodeGen.ImpGen.Kernels.Base +import Futhark.CodeGen.ImpGen.Kernels.SegRed +import Futhark.CodeGen.ImpGen (sFor, sWhen, + sOp, + dPrim, dPrim_, dPrimV) +import Futhark.CodeGen.ImpGen.Kernels.Transpose +import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun +import Futhark.CodeGen.SetDefaultSpace +import Futhark.Util.IntegralExp (quotRoundingUp, quot, IntegralExp) + +callKernelOperations :: ImpGen.Operations ExplicitMemory Imp.HostOp +callKernelOperations = + ImpGen.Operations { ImpGen.opsExpCompiler = expCompiler + , ImpGen.opsCopyCompiler = callKernelCopy + , ImpGen.opsOpCompiler = opCompiler + , ImpGen.opsStmsCompiler = ImpGen.defCompileStms + } + +compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError Imp.Program) +compileProg prog = + fmap (setDefaultSpace (Imp.Space "device")) <$> + ImpGen.compileProg callKernelOperations (Imp.Space "device") [Imp.Space "local"] prog + +opCompiler :: Pattern ExplicitMemory -> Op ExplicitMemory + -> CallKernelGen () +opCompiler dest (Alloc e space) = + ImpGen.compileAlloc dest e space +opCompiler dest (Inner kernel) = + kernelCompiler dest kernel + +sizeClassWithEntryPoint :: Name -> Imp.SizeClass -> Imp.SizeClass +sizeClassWithEntryPoint fname (Imp.SizeThreshold path) = + Imp.SizeThreshold $ map f path + where f (name, x) = (keyWithEntryPoint fname name, x) +sizeClassWithEntryPoint _ size_class = size_class + +kernelCompiler :: Pattern ExplicitMemory -> Kernel InKernel + -> CallKernelGen () + +kernelCompiler (Pattern _ [pe]) (GetSize key size_class) = do + fname <- asks ImpGen.envFunction + sOp $ Imp.GetSize (patElemName pe) (keyWithEntryPoint fname key) $ + sizeClassWithEntryPoint fname size_class + +kernelCompiler (Pattern _ [pe]) (CmpSizeLe key size_class x) = do + fname <- asks ImpGen.envFunction + let size_class' = sizeClassWithEntryPoint fname size_class + sOp . Imp.CmpSizeLe (patElemName pe) (keyWithEntryPoint fname key) size_class' + =<< ImpGen.compileSubExp x + +kernelCompiler (Pattern _ [pe]) (GetSizeMax size_class) = + sOp $ Imp.GetSizeMax (patElemName pe) size_class + +kernelCompiler pat (Kernel desc space _ kernel_body) = do + (constants, init_constants) <- kernelInitialisation space + + kernel_body' <- + makeAllMemoryGlobal $ ImpGen.subImpM_ (inKernelOperations constants) $ do + init_constants + compileKernelBody pat constants kernel_body + + let bound_in_kernel = + M.keys $ + scopeOfKernelSpace space <> + scopeOf (kernelBodyStms kernel_body) + (uses, local_memory) <- computeKernelUses kernel_body' bound_in_kernel + + forM_ (kernelHints desc) $ \(s,v) -> do + ty <- case v of + Constant pv -> return $ Prim $ primValueType pv + Var vn -> lookupType vn + unless (primType ty) $ fail $ concat [ "debugKernelHint '", s, "'" + , " in kernel '", kernelName desc, "'" + , " did not have primType value." ] + + ImpGen.compileSubExp v >>= ImpGen.emit . Imp.DebugPrint s (elemType ty) + + sOp $ Imp.CallKernel Imp.Kernel + { Imp.kernelBody = kernel_body' + , Imp.kernelLocalMemory = local_memory + , Imp.kernelUses = uses + , Imp.kernelNumGroups = [ImpGen.compileSubExpOfType int32 $ spaceNumGroups space] + , Imp.kernelGroupSize = [ImpGen.compileSubExpOfType int32 $ spaceGroupSize space] + , Imp.kernelName = nameFromString $ kernelName desc ++ "_" ++ + show (baseTag $ kernelGlobalThreadIdVar constants) + } + +-- First handle the simple case of a non-segmented reduction. Our +-- strategy is the conventional approach of generating two kernels: +-- one where each group is given a chunk of the total input and +-- produces a partial result per group, and then a final kernel that +-- combines the per-group partial results. +kernelCompiler pat (SegRed space comm red_op nes _ body) = + compileSegRed pat space comm red_op nes body + +kernelCompiler pat e = + compilerBugS $ "ImpGen.kernelCompiler: Invalid pattern\n " ++ + pretty pat ++ "\nfor expression\n " ++ pretty e + +expCompiler :: ImpGen.ExpCompiler ExplicitMemory Imp.HostOp + +-- We generate a simple kernel for itoa and replicate. +expCompiler (Pattern _ [pe]) (BasicOp (Iota n x s et)) = do + n' <- ImpGen.compileSubExp n + x' <- ImpGen.compileSubExp x + s' <- ImpGen.compileSubExp s + destloc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe) + (constants, set_constants) <- simpleKernelConstants n' "iota" + + sKernel constants "iota" $ do + set_constants + let gtid = kernelGlobalThreadId constants + sWhen (kernelThreadActive constants) $ do + (destmem, destspace, destidx) <- + ImpGen.fullyIndexArray' destloc [gtid] (IntType et) + + ImpGen.emit $ + Imp.Write destmem destidx (IntType et) destspace Imp.Nonvolatile $ + Imp.ConvOpExp (SExt Int32 et) gtid * s' + x' + +expCompiler (Pattern _ [pe]) (BasicOp (Replicate (Shape ds) se)) = do + t <- subExpType se + + dims <- mapM ImpGen.compileSubExp $ ds ++ arrayDims t + (constants, set_constants) <- + simpleKernelConstants (product dims) "replicate" + + let is' = unflattenIndex dims $ kernelGlobalThreadId constants + + sKernel constants "replicate" $ do + set_constants + sWhen (kernelThreadActive constants) $ + ImpGen.copyDWIM (patElemName pe) is' se $ drop (length ds) is' + +-- Allocation in the "local" space is just a placeholder. +expCompiler _ (Op (Alloc _ (Space "local"))) = + return () + +expCompiler dest e = + ImpGen.defCompileExp dest e + +callKernelCopy :: ImpGen.CopyCompiler ExplicitMemory Imp.HostOp +callKernelCopy bt + destloc@(ImpGen.MemLocation destmem destshape destIxFun) + srcloc@(ImpGen.MemLocation srcmem srcshape srcIxFun) + n + | Just (destoffset, srcoffset, + num_arrays, size_x, size_y, + src_elems, dest_elems) <- isMapTransposeKernel bt destloc srcloc = do + + fname <- mapTransposeForType bt + ImpGen.emit $ Imp.Call [] fname + [Imp.MemArg destmem, Imp.ExpArg destoffset, + Imp.MemArg srcmem, Imp.ExpArg srcoffset, + Imp.ExpArg num_arrays, Imp.ExpArg size_x, Imp.ExpArg size_y, + Imp.ExpArg src_elems, Imp.ExpArg dest_elems] + + | bt_size <- primByteSize bt, + ixFunMatchesInnerShape + (Shape $ map Imp.sizeToExp destshape) destIxFun, + ixFunMatchesInnerShape + (Shape $ map Imp.sizeToExp srcshape) srcIxFun, + Just destoffset <- + IxFun.linearWithOffset destIxFun bt_size, + Just srcoffset <- + IxFun.linearWithOffset srcIxFun bt_size = do + let row_size = product $ map ImpGen.dimSizeToExp $ drop 1 srcshape + srcspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory srcmem + destspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory destmem + ImpGen.emit $ Imp.Copy + destmem (bytes destoffset) destspace + srcmem (bytes srcoffset) srcspace $ + (n * row_size) `Imp.withElemType` bt + + | otherwise = do + + -- Note that the shape of the destination and the source are + -- necessarily the same. + let shape = map Imp.sizeToExp srcshape + shape_se = map (Imp.innerExp . ImpGen.dimSizeToExp) srcshape + kernel_size = Imp.innerExp n * product (drop 1 shape) + + (constants, set_constants) <- simpleKernelConstants kernel_size "copy" + + sKernel constants "copy" $ do + set_constants + + let gtid = kernelGlobalThreadId constants + dest_is = unflattenIndex shape_se gtid + src_is = dest_is + + (_, destspace, destidx) <- ImpGen.fullyIndexArray' destloc dest_is bt + (_, srcspace, srcidx) <- ImpGen.fullyIndexArray' srcloc src_is bt + + sWhen (gtid .<. kernel_size) $ ImpGen.emit $ + Imp.Write destmem destidx bt destspace Imp.Nonvolatile $ + Imp.index srcmem srcidx bt srcspace Imp.Nonvolatile + +mapTransposeForType :: PrimType -> ImpGen.ImpM ExplicitMemory Imp.HostOp Name +mapTransposeForType bt = do + -- XXX: The leading underscore is to avoid clashes with a + -- programmer-defined function of the same name (this is a bad + -- solution...). + let fname = nameFromString $ "_" <> mapTransposeName bt + + exists <- ImpGen.hasFunction fname + unless exists $ ImpGen.emitFunction fname $ mapTransposeFunction bt + + return fname + +mapTransposeName :: PrimType -> String +mapTransposeName bt = "map_transpose_" ++ pretty bt + +mapTransposeFunction :: PrimType -> Imp.Function +mapTransposeFunction bt = + Imp.Function False [] params transpose_code [] [] + + where params = [memparam destmem, intparam destoffset, + memparam srcmem, intparam srcoffset, + intparam num_arrays, intparam x, intparam y, + intparam in_elems, intparam out_elems] + + space = Space "device" + memparam v = Imp.MemParam v space + intparam v = Imp.ScalarParam v $ IntType Int32 + + [destmem, destoffset, srcmem, srcoffset, + num_arrays, x, y, in_elems, out_elems, + mulx, muly, block] = + zipWith (VName . nameFromString) + ["destmem", + "destoffset", + "srcmem", + "srcoffset", + "num_arrays", + "x_elems", + "y_elems", + "in_elems", + "out_elems", + -- The following is only used for low width/height + -- transpose kernels + "mulx", + "muly", + "block" + ] + [0..] + + v32 v = Imp.var v int32 + + block_dim_int = 16 + + block_dim :: IntegralExp a => a + block_dim = 16 + + -- When an input array has either width==1 or height==1, performing a + -- transpose will be the same as performing a copy. If 'input_size' or + -- 'output_size' is not equal to width*height, then this trick will not + -- work when there are more than one array to process, as it is a per + -- array limit. We could copy each array individually, but currently we + -- do not. + can_use_copy = + let in_out_eq = CmpOpExp (CmpEq $ IntType Int32) (v32 in_elems) (v32 out_elems) + onearr = CmpOpExp (CmpEq $ IntType Int32) (v32 num_arrays) 1 + noprob_widthheight = CmpOpExp (CmpEq $ IntType Int32) + (v32 x * v32 y) + (v32 in_elems) + height_is_one = CmpOpExp (CmpEq $ IntType Int32) (v32 y) 1 + width_is_one = CmpOpExp (CmpEq $ IntType Int32) (v32 x) 1 + in BinOpExp LogAnd + in_out_eq + (BinOpExp LogAnd + (BinOpExp LogOr onearr noprob_widthheight) + (BinOpExp LogOr width_is_one height_is_one)) + + transpose_code = + Imp.If input_is_empty mempty $ mconcat + [ Imp.DeclareScalar muly (IntType Int32) + , Imp.SetScalar muly $ block_dim `quot` v32 x + , Imp.DeclareScalar mulx (IntType Int32) + , Imp.SetScalar mulx $ block_dim `quot` v32 y + , Imp.If can_use_copy copy_code $ + Imp.If should_use_lowwidth (callTransposeKernel TransposeLowWidth) $ + Imp.If should_use_lowheight (callTransposeKernel TransposeLowHeight) $ + Imp.If should_use_small (callTransposeKernel TransposeSmall) $ + callTransposeKernel TransposeNormal] + + input_is_empty = + v32 num_arrays .==. 0 .||. v32 x .==. 0 .||. v32 y .==. 0 + + should_use_small = BinOpExp LogAnd + (CmpOpExp (CmpSle Int32) (v32 x) (block_dim `quot` 2)) + (CmpOpExp (CmpSle Int32) (v32 y) (block_dim `quot` 2)) + + should_use_lowwidth = BinOpExp LogAnd + (CmpOpExp (CmpSle Int32) (v32 x) (block_dim `quot` 2)) + (CmpOpExp (CmpSlt Int32) block_dim (v32 y)) + + should_use_lowheight = BinOpExp LogAnd + (CmpOpExp (CmpSle Int32) (v32 y) (block_dim `quot` 2)) + (CmpOpExp (CmpSlt Int32) block_dim (v32 x)) + + copy_code = + let num_bytes = + v32 in_elems * Imp.LeafExp (Imp.SizeOf bt) (IntType Int32) + in Imp.Copy + destmem (Imp.Count $ v32 destoffset) space + srcmem (Imp.Count $ v32 srcoffset) space + (Imp.Count num_bytes) + + callTransposeKernel = + Imp.Op . Imp.CallKernel . + mapTransposeKernel (mapTransposeName bt) block_dim_int + (destmem, v32 destoffset, srcmem, v32 srcoffset, + v32 x, v32 y, v32 in_elems, v32 out_elems, + v32 mulx, v32 muly, v32 num_arrays, + block) bt + +isMapTransposeKernel :: PrimType -> ImpGen.MemLocation -> ImpGen.MemLocation + -> Maybe (Imp.Exp, Imp.Exp, + Imp.Exp, Imp.Exp, Imp.Exp, + Imp.Exp, Imp.Exp) +isMapTransposeKernel bt + (ImpGen.MemLocation _ _ destIxFun) + (ImpGen.MemLocation _ _ srcIxFun) + | Just (dest_offset, perm_and_destshape) <- IxFun.rearrangeWithOffset destIxFun bt_size, + (perm, destshape) <- unzip perm_and_destshape, + srcshape' <- IxFun.shape srcIxFun, + Just src_offset <- IxFun.linearWithOffset srcIxFun bt_size, + Just (r1, r2, _) <- isMapTranspose perm = + isOk (product srcshape') (product destshape) destshape swap r1 r2 dest_offset src_offset + | Just dest_offset <- IxFun.linearWithOffset destIxFun bt_size, + Just (src_offset, perm_and_srcshape) <- IxFun.rearrangeWithOffset srcIxFun bt_size, + (perm, srcshape) <- unzip perm_and_srcshape, + destshape' <- IxFun.shape destIxFun, + Just (r1, r2, _) <- isMapTranspose perm = + isOk (product srcshape) (product destshape') srcshape id r1 r2 dest_offset src_offset + | otherwise = + Nothing + where bt_size = primByteSize bt + swap (x,y) = (y,x) + + isOk src_elems dest_elems shape f r1 r2 dest_offset src_offset = do + let (num_arrays, size_x, size_y) = getSizes shape f r1 r2 + return (dest_offset, src_offset, + num_arrays, size_x, size_y, + src_elems, dest_elems) + + getSizes shape f r1 r2 = + let (mapped, notmapped) = splitAt r1 shape + (pretrans, posttrans) = f $ splitAt r2 notmapped + in (product mapped, product pretrans, product posttrans) + +simpleKernelConstants :: Imp.Exp -> String + -> CallKernelGen (KernelConstants, ImpGen.ImpM InKernel Imp.KernelOp ()) +simpleKernelConstants kernel_size desc = do + thread_gtid <- newVName $ desc ++ "_gtid" + thread_ltid <- newVName $ desc ++ "_ltid" + group_id <- newVName $ desc ++ "_gid" + (group_size, num_groups) <- computeMapKernelGroups kernel_size + let set_constants = do + dPrim_ thread_gtid int32 + dPrim_ thread_ltid int32 + dPrim_ group_id int32 + sOp (Imp.GetGlobalId thread_gtid 0) + sOp (Imp.GetLocalId thread_ltid 0) + sOp (Imp.GetGroupId group_id 0) + + return (KernelConstants + (Imp.var thread_gtid int32) (Imp.var thread_ltid int32) (Imp.var group_id int32) + thread_gtid thread_ltid group_id + group_size num_groups (group_size*num_groups) 0 + [] (Imp.var thread_gtid int32 .<. kernel_size) mempty, + + set_constants) + +computeMapKernelGroups :: Imp.Exp -> CallKernelGen (Imp.Exp, Imp.Exp) +computeMapKernelGroups kernel_size = do + group_size <- dPrim "group_size" int32 + fname <- asks ImpGen.envFunction + let group_size_var = Imp.var group_size int32 + group_size_key = keyWithEntryPoint fname $ nameFromString $ pretty group_size + sOp $ Imp.GetSize group_size group_size_key Imp.SizeGroup + num_groups <- dPrimV "num_groups" $ kernel_size `quotRoundingUp` Imp.ConvOpExp (SExt Int32 Int32) group_size_var + return (Imp.var group_size int32, Imp.var num_groups int32) + +compileKernelBody :: Pattern InKernel + -> KernelConstants + -> KernelBody InKernel + -> InKernelGen () +compileKernelBody pat constants kbody = + compileKernelStms constants (stmsToList $ kernelBodyStms kbody) $ + zipWithM_ (compileKernelResult constants) (patternElements pat) $ + kernelBodyResult kbody + +compileKernelResult :: KernelConstants -> PatElem InKernel -> KernelResult + -> InKernelGen () + +compileKernelResult constants pe (ThreadsReturn OneResultPerGroup what) = do + i <- newVName "i" + + in_local_memory <- arrayInLocalMemory what + let me = kernelLocalThreadId constants + + if not in_local_memory then do + who' <- ImpGen.compileSubExp $ intConst Int32 0 + sWhen (me .==. who') $ + ImpGen.copyDWIM (patElemName pe) [kernelGroupId constants] what [] + else do + -- If the result of the group is an array in local memory, we + -- store it by collective copying among all the threads of the + -- group. TODO: also do this if the array is in global memory + -- (but this is a bit more tricky, synchronisation-wise). + -- + -- We do the reads/writes multidimensionally, but the loop is + -- single-dimensional. + ws <- mapM ImpGen.compileSubExp . arrayDims =<< subExpType what + -- Compute how many elements this thread is responsible for. + -- Formula: (w - ltid) / group_size (rounded up). + let w = product ws + ltid = kernelLocalThreadId constants + group_size = kernelGroupSize constants + to_write = (w - ltid) `quotRoundingUp` group_size + is = unflattenIndex ws $ ImpGen.varIndex i * group_size + ltid + + sFor i Int32 to_write $ + ImpGen.copyDWIM (patElemName pe) (kernelGroupId constants : is) what is + +compileKernelResult constants pe (ThreadsReturn AllThreads what) = + ImpGen.copyDWIM (patElemName pe) [kernelGlobalThreadId constants] what [] + +compileKernelResult constants pe (ThreadsReturn (ThreadsPerGroup limit) what) = + sWhen (isActive limit) $ + ImpGen.copyDWIM (patElemName pe) [kernelGroupId constants] what [] + +compileKernelResult constants pe (ThreadsReturn ThreadsInSpace what) = do + let is = map (ImpGen.varIndex . fst) $ kernelDimensions constants + sWhen (kernelThreadActive constants) $ ImpGen.copyDWIM (patElemName pe) is what [] + +compileKernelResult constants pe (ConcatReturns SplitContiguous _ per_thread_elems moffset what) = do + dest_loc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe) + let dest_loc_offset = ImpGen.offsetArray dest_loc offset + dest' = ImpGen.arrayDestination dest_loc_offset + ImpGen.copyDWIMDest dest' [] (Var what) [] + where offset = case moffset of + Nothing -> ImpGen.compileSubExpOfType int32 per_thread_elems * + kernelGlobalThreadId constants + Just se -> ImpGen.compileSubExpOfType int32 se + +compileKernelResult constants pe (ConcatReturns (SplitStrided stride) _ _ moffset what) = do + dest_loc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe) + let dest_loc' = ImpGen.strideArray + (ImpGen.offsetArray dest_loc offset) $ + ImpGen.compileSubExpOfType int32 stride + dest' = ImpGen.arrayDestination dest_loc' + ImpGen.copyDWIMDest dest' [] (Var what) [] + where offset = case moffset of + Nothing -> kernelGlobalThreadId constants + Just se -> ImpGen.compileSubExpOfType int32 se + +compileKernelResult constants pe (WriteReturn rws _arr dests) = do + rws' <- mapM ImpGen.compileSubExp rws + forM_ dests $ \(is, e) -> do + is' <- mapM ImpGen.compileSubExp is + let condInBounds i rw = 0 .<=. i .&&. i .<. rw + write = foldl (.&&.) (kernelThreadActive constants) $ + zipWith condInBounds is' rws' + sWhen write $ ImpGen.copyDWIM (patElemName pe) (map (ImpGen.compileSubExpOfType int32) is) e [] + +compileKernelResult _ _ KernelInPlaceReturn{} = + -- Already in its place... said it was a hack. + return () arrayInLocalMemory :: SubExp -> InKernelGen Bool arrayInLocalMemory (Var name) = do diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs @@ -0,0 +1,960 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +module Futhark.CodeGen.ImpGen.Kernels.Base + ( KernelConstants (..) + , inKernelOperations + , computeKernelUses + , keyWithEntryPoint + , CallKernelGen + , InKernelGen + , computeThreadChunkSize + , kernelInitialisation + , kernelInitialisationSetSpace + , setSpaceIndices + , makeAllMemoryGlobal + , allThreads + , compileKernelStms + , groupReduce + , groupScan + , isActive + , sKernel + ) + where + +import Control.Arrow ((&&&)) +import Control.Monad.Except +import Control.Monad.Reader +import Data.Maybe +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.List + +import Prelude hiding (quot) + +import Futhark.Error +import Futhark.MonadFreshNames +import Futhark.Transform.Rename +import Futhark.Representation.ExplicitMemory +import qualified Futhark.CodeGen.ImpCode.Kernels as Imp +import Futhark.CodeGen.ImpCode.Kernels (bytes) +import qualified Futhark.CodeGen.ImpGen as ImpGen +import Futhark.CodeGen.ImpGen ((<--), + sFor, sWhile, sComment, sIf, sWhen, sUnless, + sOp, + dPrim, dPrim_, dPrimV) +import Futhark.Tools (partitionChunkedKernelLambdaParameters) +import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem, IntegralExp) +import Futhark.Util (splitAt3, maybeNth) + +type CallKernelGen = ImpGen.ImpM ExplicitMemory Imp.HostOp +type InKernelGen = ImpGen.ImpM InKernel Imp.KernelOp + +data KernelConstants = KernelConstants + { kernelGlobalThreadId :: Imp.Exp + , kernelLocalThreadId :: Imp.Exp + , kernelGroupId :: Imp.Exp + , kernelGlobalThreadIdVar :: VName + , kernelLocalThreadIdVar :: VName + , kernelGroupIdVar :: VName + , kernelGroupSize :: Imp.Exp + , kernelNumGroups :: Imp.Exp + , kernelNumThreads :: Imp.Exp + , kernelWaveSize :: Imp.Exp + , kernelDimensions :: [(VName, Imp.Exp)] + , kernelThreadActive :: Imp.Exp + , kernelStreamed :: [(VName, Imp.DimSize)] + -- ^ Chunk sizes and their maximum size. Hint + -- for unrolling. + } + +inKernelOperations :: KernelConstants -> ImpGen.Operations InKernel Imp.KernelOp +inKernelOperations constants = (ImpGen.defaultOperations $ compileInKernelOp constants) + { ImpGen.opsCopyCompiler = inKernelCopy + , ImpGen.opsExpCompiler = inKernelExpCompiler + , ImpGen.opsStmsCompiler = \_ -> compileKernelStms constants + } + +keyWithEntryPoint :: Name -> Name -> Name +keyWithEntryPoint fname key = + nameFromString $ nameToString fname ++ "." ++ nameToString key + +-- | We have no bulk copy operation (e.g. memmove) inside kernels, so +-- turn any copy into a loop. +inKernelCopy :: ImpGen.CopyCompiler InKernel Imp.KernelOp +inKernelCopy = ImpGen.copyElementWise + +compileInKernelOp :: KernelConstants -> Pattern InKernel -> Op InKernel + -> InKernelGen () +compileInKernelOp _ (Pattern _ [mem]) Alloc{} = + compilerLimitationS $ "Cannot allocate memory block " ++ pretty mem ++ " in kernel." +compileInKernelOp _ dest Alloc{} = + compilerBugS $ "Invalid target for in-kernel allocation: " ++ show dest +compileInKernelOp constants pat (Inner op) = + compileKernelExp constants pat op + +inKernelExpCompiler :: ImpGen.ExpCompiler InKernel Imp.KernelOp +inKernelExpCompiler _ (BasicOp (Assert _ _ (loc, locs))) = + compilerLimitationS $ + unlines [ "Cannot compile assertion at " ++ + intercalate " -> " (reverse $ map locStr $ loc:locs) ++ + " inside parallel kernel." + , "As a workaround, surround the expression with 'unsafe'."] +-- The static arrays stuff does not work inside kernels. +inKernelExpCompiler (Pattern _ [dest]) (BasicOp (ArrayLit es _)) = + forM_ (zip [0..] es) $ \(i,e) -> + ImpGen.copyDWIM (patElemName dest) [fromIntegral (i::Int32)] e [] +inKernelExpCompiler dest e = + ImpGen.defCompileExp dest e + +compileKernelExp :: KernelConstants -> Pattern InKernel -> KernelExp InKernel + -> InKernelGen () + +compileKernelExp _ pat (Barrier ses) = do + forM_ (zip (patternNames pat) ses) $ \(d, se) -> + ImpGen.copyDWIM d [] se [] + sOp Imp.LocalBarrier + +compileKernelExp _ (Pattern [] [size]) (SplitSpace o w i elems_per_thread) = do + num_elements <- Imp.elements <$> ImpGen.compileSubExp w + i' <- ImpGen.compileSubExp i + elems_per_thread' <- Imp.elements <$> ImpGen.compileSubExp elems_per_thread + computeThreadChunkSize o i' elems_per_thread' num_elements (patElemName size) + +compileKernelExp constants pat (Combine (CombineSpace scatter cspace) _ aspace body) = do + -- First we compute how many times we have to iterate to cover + -- cspace with our group size. It is a fairly common case that + -- we statically know that this requires 1 iteration, so we + -- could detect it and not generate a loop in that case. + -- However, it seems to have no impact on performance (an extra + -- conditional jump), so for simplicity we just always generate + -- the loop. + let cspace_dims = map (streamBounded . snd) cspace + num_iters + | cspace_dims == [kernelGroupSize constants] = 1 + | otherwise = product cspace_dims `quotRoundingUp` + kernelGroupSize constants + + iter <- newVName "comb_iter" + + sFor iter Int32 num_iters $ do + mapM_ ((`dPrim_` int32) . fst) cspace + -- Compute the *flat* array index. + cid <- dPrimV "flat_comb_id" $ + Imp.var iter int32 * kernelGroupSize constants + + kernelLocalThreadId constants + + -- Turn it into a nested array index. + zipWithM_ (<--) (map fst cspace) $ unflattenIndex cspace_dims (Imp.var cid int32) + + -- Construct the body. This is mostly about the book-keeping + -- for the scatter-like part. + let (scatter_ws, scatter_ns, _scatter_vs) = unzip3 scatter + scatter_ws_repl = concat $ zipWith replicate scatter_ns scatter_ws + (scatter_pes, normal_pes) = + splitAt (sum scatter_ns) $ patternElements pat + (res_is, res_vs, res_normal) = + splitAt3 (sum scatter_ns) (sum scatter_ns) $ bodyResult body + + -- Execute the body if we are within bounds. + sWhen (isActive cspace .&&. isActive aspace) $ allThreads constants $ + ImpGen.compileStms (freeIn $ bodyResult body) (stmsToList $ bodyStms body) $ do + + forM_ (zip4 scatter_ws_repl res_is res_vs scatter_pes) $ + \(w, res_i, res_v, scatter_pe) -> do + let res_i' = ImpGen.compileSubExpOfType int32 res_i + w' = ImpGen.compileSubExpOfType int32 w + -- We have to check that 'res_i' is in-bounds wrt. an array of size 'w'. + in_bounds = 0 .<=. res_i' .&&. res_i' .<. w' + sWhen in_bounds $ ImpGen.copyDWIM (patElemName scatter_pe) [res_i'] res_v [] + + forM_ (zip normal_pes res_normal) $ \(pe, res) -> + ImpGen.copyDWIM (patElemName pe) local_index res [] + + sOp Imp.LocalBarrier + + where streamBounded (Var v) + | Just x <- lookup v $ kernelStreamed constants = + Imp.sizeToExp x + streamBounded se = ImpGen.compileSubExpOfType int32 se + + local_index = map (ImpGen.compileSubExpOfType int32 . Var . fst) cspace + +compileKernelExp constants (Pattern _ dests) (GroupReduce w lam input) = do + let [my_index_param, offset_param] = take 2 $ lambdaParams lam + lam' = lam { lambdaParams = drop 2 $ lambdaParams lam } + + dPrim_ (paramName my_index_param) int32 + dPrim_ (paramName offset_param) int32 + paramName my_index_param <-- kernelGlobalThreadId constants + w' <- ImpGen.compileSubExp w + groupReduceWithOffset constants (paramName offset_param) w' lam' $ map snd input + + sOp Imp.LocalBarrier + + -- The final result will be stored in element 0 of the local memory array. + forM_ (zip dests input) $ \(dest, (_, arr)) -> + ImpGen.copyDWIM (patElemName dest) [] (Var arr) [0] + +compileKernelExp constants _ (GroupScan w lam input) = do + w' <- ImpGen.compileSubExp w + groupScan constants Nothing w' lam $ map snd input + +compileKernelExp constants (Pattern _ final) (GroupStream w maxchunk lam accs _arrs) = do + let GroupStreamLambda block_size block_offset acc_params arr_params body = lam + block_offset' = Imp.var block_offset int32 + w' <- ImpGen.compileSubExp w + max_block_size <- ImpGen.compileSubExp maxchunk + + ImpGen.dLParams (acc_params++arr_params) + zipWithM_ ImpGen.compileSubExpTo (map paramName acc_params) accs + dPrim_ block_size int32 + + -- If the GroupStream is morally just a do-loop, generate simpler code. + case mapM isSimpleThreadInSpace $ stmsToList $ bodyStms body of + Just stms' | ValueExp x <- max_block_size, oneIsh x -> do + let body' = body { bodyStms = stmsFromList stms' } + body'' = allThreads constants $ + ImpGen.compileLoopBody (map paramName acc_params) body' + block_size <-- 1 + + -- Check if loop is candidate for unrolling. + let loop = + case w of + Var w_var | Just w_bound <- lookup w_var $ kernelStreamed constants, + w_bound /= Imp.ConstSize 1 -> + -- Candidate for unrolling, so generate two loops. + sIf (w' .==. Imp.sizeToExp w_bound) + (sFor block_offset Int32 (Imp.sizeToExp w_bound) body'') + (sFor block_offset Int32 w' body'') + _ -> sFor block_offset Int32 w' body'' + + if kernelThreadActive constants == Imp.ValueExp (BoolValue True) + then loop + else sWhen (kernelThreadActive constants) loop + + _ -> do + dPrim_ block_offset int32 + let body' = streaming constants block_size maxchunk $ + ImpGen.compileBody' acc_params body + + block_offset <-- 0 + + let not_at_end = block_offset' .<. w' + set_block_size = + sIf (w' - block_offset' .<. max_block_size) + (block_size <-- (w' - block_offset')) + (block_size <-- max_block_size) + increase_offset = + block_offset <-- block_offset' + max_block_size + + -- Three cases to consider for simpler generated code based + -- on max block size: (0) if full input size, do not + -- generate a loop; (1) if one, generate for-loop (2) + -- otherwise, generate chunked while-loop. + if max_block_size == w' then + (block_size <-- w') >> body' + else if max_block_size == Imp.ValueExp (value (1::Int32)) then do + block_size <-- w' + sFor block_offset Int32 w' body' + else + sWhile not_at_end $ + set_block_size >> body' >> increase_offset + + forM_ (zip final acc_params) $ \(pe, p) -> + ImpGen.copyDWIM (patElemName pe) [] (Var $ paramName p) [] + + where isSimpleThreadInSpace (Let _ _ Op{}) = Nothing + isSimpleThreadInSpace bnd = Just bnd + +compileKernelExp _ _ (GroupGenReduce w arrs op bucket values locks) = do + -- Check if bucket is in-bounds + bucket' <- mapM ImpGen.compileSubExp bucket + w' <- mapM ImpGen.compileSubExp w + sWhen (indexInBounds bucket' w') $ + atomicUpdate arrs bucket op values locking + where indexInBounds inds bounds = + foldl1 (.&&.) $ zipWith checkBound inds bounds + where checkBound ind bound = 0 .<=. ind .&&. ind .<. bound + locking = Locking locks 0 1 0 + +compileKernelExp _ dest e = + compilerBugS $ unlines ["Invalid target", " " ++ show dest, + "for kernel expression", " " ++ pretty e] + +streaming :: KernelConstants -> VName -> SubExp -> InKernelGen () -> InKernelGen () +streaming constants chunksize bound m = do + bound' <- ImpGen.subExpToDimSize bound + let constants' = + constants { kernelStreamed = (chunksize, bound') : kernelStreamed constants } + ImpGen.emit =<< ImpGen.subImpM_ (inKernelOperations constants') m + +-- | Locking strategy used for an atomic update. +data Locking = Locking { lockingArray :: VName -- ^ Array containing the lock. + , lockingIsUnlocked :: Imp.Exp -- ^ Value for us to consider the lock free. + , lockingToLock :: Imp.Exp -- ^ What to write when we lock it. + , lockingToUnlock :: Imp.Exp -- ^ What to write when we unlock it. + } + +atomicUpdate :: ExplicitMemorish lore => + [VName] -> [SubExp] -> Lambda lore -> [SubExp] -> Locking + -> ImpGen.ImpM lore Imp.KernelOp () + +atomicUpdate arrs bucket lam values _ + | Just ops_and_ts <- splitOp lam, + all ((==32) . primBitSize . snd) ops_and_ts = + -- 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 + -- is still a binary operator which can be implemented by atomic + -- compare-and-swap if 32 bits. + forM_ (zip3 arrs ops_and_ts values) $ \(a, (op, t), val) -> do + + -- Common variables. + old <- dPrim "old" t + bucket' <- mapM ImpGen.compileSubExp bucket + + (arr', _a_space, bucket_offset) <- ImpGen.fullyIndexArray a bucket' + + val' <- ImpGen.compileSubExp val + case opHasAtomicSupport old arr' bucket_offset op of + Just f -> sOp $ f val' + + Nothing -> do + -- Code generation target: + -- + -- old = d_his[idx]; + -- do { + -- assumed = old; + -- tmp = OP::apply(val, assumed); + -- old = atomicCAS(&d_his[idx], assumed, tmp); + -- } while(assumed != old); + assumed <- dPrim "assumed" t + run_loop <- dPrimV "run_loop" 1 + ImpGen.copyDWIM old [] (Var a) bucket' + + -- Critical section + x <- dPrim "x" t + y <- dPrim "y" t + + -- While-loop: Try to insert your value + let (toBits, fromBits) = + case t of FloatType Float32 -> (\v -> Imp.FunExp "to_bits32" [v] int32, + \v -> Imp.FunExp "from_bits32" [v] t) + _ -> (id, id) + sWhile (Imp.var run_loop int32) $ do + assumed <-- Imp.var old t + x <-- val' + y <-- Imp.var assumed t + x <-- Imp.BinOpExp op (Imp.var x t) (Imp.var y t) + old_bits <- dPrim "old_bits" int32 + sOp $ Imp.Atomic $ + Imp.AtomicCmpXchg old_bits arr' bucket_offset + (toBits (Imp.var assumed t)) (toBits (Imp.var x t)) + old <-- fromBits (Imp.var old_bits int32) + sWhen (toBits (Imp.var assumed t) .==. Imp.var old_bits int32) + (run_loop <-- 0) + + where opHasAtomicSupport old arr' bucket' bop = do + let atomic f = Imp.Atomic . f old arr' bucket' + atomic <$> Imp.atomicBinOp bop + +atomicUpdate arrs bucket op values locking = do + old <- dPrim "old" int32 + continue <- dPrimV "continue" true + + -- Check if bucket is in-bounds + bucket' <- mapM ImpGen.compileSubExp bucket + + -- Correctly index into locks. + (locks', _locks_space, locks_offset) <- + ImpGen.fullyIndexArray (lockingArray locking) bucket' + + -- Preparing parameters + let (acc_params, arr_params) = + splitAt (length values) $ lambdaParams op + + -- Critical section + let try_acquire_lock = + sOp $ Imp.Atomic $ + Imp.AtomicCmpXchg old locks' locks_offset (lockingIsUnlocked locking) (lockingToLock locking) + lock_acquired = Imp.var old int32 .==. lockingIsUnlocked locking + release_lock = ImpGen.everythingVolatile $ + ImpGen.sWrite (lockingArray locking) bucket' $ lockingToUnlock locking + break_loop = continue <-- false + + -- We copy the current value and the new value to the parameters. + -- It is important that the right-hand-side is bound first for the + -- (rare) case when we are dealing with arrays. + let bind_acc_params = + ImpGen.sComment "bind lhs" $ + forM_ (zip acc_params arrs) $ \(acc_p, arr) -> + ImpGen.copyDWIM (paramName acc_p) [] (Var arr) bucket' + + let bind_arr_params = + ImpGen.sComment "bind rhs" $ + forM_ (zip arr_params values) $ \(arr_p, val) -> + ImpGen.copyDWIM (paramName arr_p) [] val [] + + let op_body = ImpGen.sComment "execute operation" $ + ImpGen.compileBody' acc_params $ lambdaBody op + + do_gen_reduce = ImpGen.sComment "update global result" $ + zipWithM_ (writeArray bucket') arrs $ map (Var . paramName) acc_params + + -- While-loop: Try to insert your value + sWhile (Imp.var continue Bool) $ do + try_acquire_lock + sWhen lock_acquired $ do + ImpGen.dLParams $ lambdaParams op + bind_arr_params + bind_acc_params + op_body + do_gen_reduce + release_lock + break_loop + sOp Imp.MemFence + where writeArray bucket' arr val = + ImpGen.copyDWIM arr bucket' val [] + +-- | Horizontally fission a lambda that models a binary operator. +splitOp :: Attributes lore => Lambda lore -> Maybe [(BinOp, PrimType)] +splitOp lam = mapM splitStm $ bodyResult $ lambdaBody lam + where n = length $ lambdaReturnType lam + splitStm :: SubExp -> Maybe (BinOp, PrimType) + splitStm (Var res) = do + Let (Pattern [] [pe]) _ (BasicOp (BinOp op (Var x) (Var y))) <- + find (([res]==) . patternNames . stmPattern) $ + stmsToList $ bodyStms $ lambdaBody lam + i <- Var res `elemIndex` bodyResult (lambdaBody lam) + xp <- maybeNth i $ lambdaParams lam + yp <- maybeNth (n+i) $ lambdaParams lam + guard $ paramName xp == x + guard $ paramName yp == y + Prim t <- Just $ patElemType pe + return (op, t) + splitStm _ = Nothing + +computeKernelUses :: FreeIn a => + a -> [VName] + -> CallKernelGen ([Imp.KernelUse], [Imp.LocalMemoryUse]) +computeKernelUses kernel_body bound_in_kernel = do + let actually_free = freeIn kernel_body `S.difference` S.fromList bound_in_kernel + + -- Compute the variables that we need to pass to the kernel. + reads_from <- readsFromSet actually_free + + -- Are we using any local memory? + local_memory <- computeLocalMemoryUse actually_free + return (nub reads_from, nub local_memory) + +readsFromSet :: Names -> CallKernelGen [Imp.KernelUse] +readsFromSet free = + fmap catMaybes $ + forM (S.toList free) $ \var -> do + t <- lookupType var + case t of + Array {} -> return Nothing + Mem _ (Space "local") -> return Nothing + Mem {} -> return $ Just $ Imp.MemoryUse var + Prim bt -> + isConstExp var >>= \case + Just ce -> return $ Just $ Imp.ConstUse var ce + Nothing | bt == Cert -> return Nothing + | otherwise -> return $ Just $ Imp.ScalarUse var bt + +computeLocalMemoryUse :: Names -> CallKernelGen [Imp.LocalMemoryUse] +computeLocalMemoryUse free = + fmap catMaybes $ + forM (S.toList free) $ \var -> do + t <- lookupType var + case t of + Mem memsize (Space "local") -> do + memsize' <- localMemSize =<< ImpGen.subExpToDimSize memsize + return $ Just (var, memsize') + _ -> return Nothing + +localMemSize :: Imp.MemSize -> CallKernelGen (Either Imp.MemSize Imp.KernelConstExp) +localMemSize (Imp.ConstSize x) = + return $ Right $ ValueExp $ IntValue $ Int64Value x +localMemSize (Imp.VarSize v) = isConstExp v >>= \case + Just e | isStaticExp e -> return $ Right e + _ -> return $ Left $ Imp.VarSize v + +isConstExp :: VName -> CallKernelGen (Maybe Imp.KernelConstExp) +isConstExp v = do + vtable <- ImpGen.getVTable + fname <- asks ImpGen.envFunction + let lookupConstExp name = constExp =<< hasExp =<< M.lookup name vtable + constExp (Op (Inner (GetSize key _))) = + Just $ LeafExp (Imp.SizeConst $ keyWithEntryPoint fname key) int32 + constExp e = primExpFromExp lookupConstExp e + return $ lookupConstExp v + where hasExp (ImpGen.ArrayVar e _) = e + hasExp (ImpGen.ScalarVar e _) = e + hasExp (ImpGen.MemVar e _) = e + +-- | Only some constant expressions quality 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 daring an array in C. +isStaticExp :: Imp.KernelConstExp -> Bool +isStaticExp LeafExp{} = True +isStaticExp ValueExp{} = True +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.Count Imp.Elements + -> VName + -> ImpGen.ImpM lore op () +computeThreadChunkSize (SplitStrided stride) thread_index elements_per_thread num_elements chunk_var = do + stride' <- ImpGen.compileSubExp stride + chunk_var <-- + Imp.BinOpExp (SMin Int32) + (Imp.innerExp elements_per_thread) + ((Imp.innerExp num_elements - thread_index) `quotRoundingUp` stride') + +computeThreadChunkSize SplitContiguous thread_index elements_per_thread num_elements chunk_var = do + starting_point <- dPrimV "starting_point" $ + thread_index * Imp.innerExp elements_per_thread + remaining_elements <- dPrimV "remaining_elements" $ + Imp.innerExp num_elements - Imp.var starting_point int32 + + let no_remaining_elements = Imp.var remaining_elements int32 .<=. 0 + beyond_bounds = Imp.innerExp num_elements .<=. Imp.var starting_point int32 + + sIf (no_remaining_elements .||. beyond_bounds) + (chunk_var <-- 0) + (sIf is_last_thread + (chunk_var <-- Imp.innerExp last_thread_elements) + (chunk_var <-- Imp.innerExp elements_per_thread)) + where last_thread_elements = + num_elements - Imp.elements thread_index * elements_per_thread + is_last_thread = + Imp.innerExp num_elements .<. + (thread_index + 1) * Imp.innerExp elements_per_thread + +kernelInitialisationSetSpace :: KernelSpace -> InKernelGen () + -> ImpGen.ImpM lore op (KernelConstants, ImpGen.ImpM InKernel Imp.KernelOp ()) +kernelInitialisationSetSpace space set_space = do + group_size' <- ImpGen.compileSubExp $ spaceGroupSize space + num_threads' <- ImpGen.compileSubExp $ spaceNumThreads space + num_groups <- ImpGen.compileSubExp $ spaceNumGroups space + + let global_tid = spaceGlobalId space + local_tid = spaceLocalId space + group_id = spaceGroupId space + wave_size <- newVName "wave_size" + inner_group_size <- newVName "group_size" + + let (space_is, space_dims) = unzip $ spaceDimensions space + space_dims' <- mapM ImpGen.compileSubExp space_dims + let constants = + KernelConstants + (Imp.var global_tid int32) + (Imp.var local_tid int32) + (Imp.var group_id int32) + global_tid local_tid group_id + group_size' num_groups num_threads' + (Imp.var wave_size int32) (zip space_is space_dims') + (if null (spaceDimensions space) + then true else isActive (spaceDimensions space)) mempty + + let set_constants = do + dPrim_ wave_size int32 + dPrim_ inner_group_size int32 + ImpGen.dScope Nothing (scopeOfKernelSpace space) + + sOp (Imp.GetGlobalId global_tid 0) + sOp (Imp.GetLocalId local_tid 0) + sOp (Imp.GetLocalSize inner_group_size 0) + sOp (Imp.GetLockstepWidth wave_size) + sOp (Imp.GetGroupId group_id 0) + + set_space + + return (constants, set_constants) + +kernelInitialisation :: KernelSpace + -> ImpGen.ImpM lore op (KernelConstants, ImpGen.ImpM InKernel Imp.KernelOp ()) +kernelInitialisation space = + kernelInitialisationSetSpace space $ + setSpaceIndices (Imp.var (spaceGlobalId space) int32) space + +setSpaceIndices :: Imp.Exp -> KernelSpace -> InKernelGen () +setSpaceIndices gtid space = + case spaceStructure space of + FlatThreadSpace is_and_dims -> + flatSpaceWith gtid is_and_dims + NestedThreadSpace is_and_dims -> do + let (gtids, gdims, ltids, ldims) = unzip4 is_and_dims + gdims' <- mapM ImpGen.compileSubExp gdims + ldims' <- mapM ImpGen.compileSubExp ldims + let (gtid_es, ltid_es) = unzip $ unflattenNestedIndex gdims' ldims' gtid + zipWithM_ (<--) gtids gtid_es + zipWithM_ (<--) ltids ltid_es + where flatSpaceWith base is_and_dims = do + let (is, dims) = unzip is_and_dims + dims' <- mapM ImpGen.compileSubExp dims + let index_expressions = unflattenIndex dims' base + zipWithM_ (<--) is index_expressions + +isActive :: [(VName, SubExp)] -> Imp.Exp +isActive limit = case actives of + [] -> Imp.ValueExp $ BoolValue True + x:xs -> foldl (.&&.) x xs + where (is, ws) = unzip limit + actives = zipWith active is $ map (ImpGen.compileSubExpOfType Bool) ws + active i = (Imp.var i int32 .<.) + +unflattenNestedIndex :: IntegralExp num => [num] -> [num] -> num -> [(num,num)] +unflattenNestedIndex global_dims group_dims global_id = + zip global_is local_is + where num_groups_dims = zipWith quotRoundingUp global_dims group_dims + group_size = product group_dims + group_id = global_id `Futhark.Util.IntegralExp.quot` group_size + local_id = global_id `Futhark.Util.IntegralExp.rem` group_size + + group_is = unflattenIndex num_groups_dims group_id + local_is = unflattenIndex group_dims local_id + global_is = zipWith (+) local_is $ zipWith (*) group_is group_dims + + +-- | Change every memory block to be in the global address space, +-- except those who are in the local memory space. This only affects +-- generated code - we still need to make sure that the memory is +-- actually present on the device (and dared as variables in the +-- kernel). +makeAllMemoryGlobal :: CallKernelGen a -> CallKernelGen a +makeAllMemoryGlobal = + local (\env -> env { ImpGen.envDefaultSpace = Imp.Space "global" }) . + ImpGen.localVTable (M.map globalMemory) + where globalMemory (ImpGen.MemVar _ entry) + | ImpGen.entryMemSpace entry /= Space "local" = + ImpGen.MemVar Nothing entry { ImpGen.entryMemSpace = Imp.Space "global" } + globalMemory entry = + entry + +allThreads :: KernelConstants -> InKernelGen () -> InKernelGen () +allThreads constants = ImpGen.emit <=< ImpGen.subImpM_ (inKernelOperations constants') + where constants' = + constants { kernelThreadActive = Imp.ValueExp (BoolValue True) } + + + +writeParamToLocalMemory :: Typed (MemBound u) => + Imp.Exp -> (VName, t) -> Param (MemBound u) + -> ImpGen.ImpM lore op () +writeParamToLocalMemory i (mem, _) param + | Prim t <- paramType param = + ImpGen.emit $ + Imp.Write mem (bytes i') bt (Space "local") Imp.Volatile $ + Imp.var (paramName param) t + | otherwise = + return () + where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32 + bt = elemType $ paramType param + +readParamFromLocalMemory :: Typed (MemBound u) => + VName -> Imp.Exp -> Param (MemBound u) -> (VName, t) + -> ImpGen.ImpM lore op () +readParamFromLocalMemory index i param (l_mem, _) + | Prim _ <- paramType param = + paramName param <-- + Imp.index l_mem (bytes i') bt (Space "local") Imp.Volatile + | otherwise = index <-- i + where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32 + bt = elemType $ paramType param + +groupReduce :: ExplicitMemorish lore => + KernelConstants + -> Imp.Exp + -> Lambda lore + -> [VName] + -> ImpGen.ImpM lore Imp.KernelOp () +groupReduce constants w lam arrs = do + offset <- dPrim "offset" int32 + groupReduceWithOffset constants offset w lam arrs + +groupReduceWithOffset :: ExplicitMemorish lore => + KernelConstants + -> VName + -> Imp.Exp + -> Lambda lore + -> [VName] + -> ImpGen.ImpM lore Imp.KernelOp () +groupReduceWithOffset constants offset w lam arrs = do + let (reduce_acc_params, reduce_arr_params) = splitAt (length arrs) $ lambdaParams lam + + skip_waves <- dPrim "skip_waves" int32 + ImpGen.dLParams $ lambdaParams lam + + offset <-- 0 + + ImpGen.comment "participating threads read initial accumulator" $ + sWhen (local_tid .<. w) $ + zipWithM_ readReduceArgument reduce_acc_params arrs + + let do_reduce = do ImpGen.comment "read array element" $ + zipWithM_ readReduceArgument reduce_arr_params arrs + ImpGen.comment "apply reduction operation" $ + ImpGen.compileBody' reduce_acc_params $ lambdaBody lam + ImpGen.comment "write result of operation" $ + zipWithM_ writeReduceOpResult reduce_acc_params arrs + in_wave_reduce = ImpGen.everythingVolatile do_reduce + + wave_size = kernelWaveSize constants + group_size = kernelGroupSize constants + wave_id = local_tid `quot` wave_size + in_wave_id = local_tid - wave_id * wave_size + num_waves = (group_size + wave_size - 1) `quot` wave_size + arg_in_bounds = local_tid + Imp.var offset int32 .<. w + + doing_in_wave_reductions = + Imp.var offset int32 .<. wave_size + apply_in_in_wave_iteration = + (in_wave_id .&. (2 * Imp.var offset int32 - 1)) .==. 0 + in_wave_reductions = do + offset <-- 1 + sWhile doing_in_wave_reductions $ do + sWhen (arg_in_bounds .&&. apply_in_in_wave_iteration) + in_wave_reduce + offset <-- Imp.var offset int32 * 2 + + doing_cross_wave_reductions = + Imp.var skip_waves int32 .<. num_waves + is_first_thread_in_wave = + in_wave_id .==. 0 + wave_not_skipped = + (wave_id .&. (2 * Imp.var skip_waves int32 - 1)) .==. 0 + apply_in_cross_wave_iteration = + arg_in_bounds .&&. is_first_thread_in_wave .&&. wave_not_skipped + cross_wave_reductions = do + skip_waves <-- 1 + sWhile doing_cross_wave_reductions $ do + barrier + offset <-- Imp.var skip_waves int32 * wave_size + sWhen apply_in_cross_wave_iteration + do_reduce + skip_waves <-- Imp.var skip_waves int32 * 2 + + in_wave_reductions + cross_wave_reductions + where local_tid = kernelLocalThreadId constants + global_tid = kernelGlobalThreadId constants + + barrier + | all primType $ lambdaReturnType lam = sOp Imp.LocalBarrier + | otherwise = sOp Imp.GlobalBarrier + + readReduceArgument param arr + | Prim _ <- paramType param = do + let i = local_tid + ImpGen.varIndex offset + ImpGen.copyDWIM (paramName param) [] (Var arr) [i] + | otherwise = do + let i = global_tid + ImpGen.varIndex offset + ImpGen.copyDWIM (paramName param) [] (Var arr) [i] + + writeReduceOpResult param arr + | Prim _ <- paramType param = + ImpGen.copyDWIM arr [local_tid] (Var $ paramName param) [] + | otherwise = + return () + +groupScan :: KernelConstants + -> Maybe (Imp.Exp -> Imp.Exp -> Imp.Exp) + -> Imp.Exp + -> Lambda InKernel + -> [VName] + -> ImpGen.ImpM InKernel Imp.KernelOp () +groupScan constants seg_flag w lam arrs = do + when (any (not . primType . paramType) $ lambdaParams lam) $ + compilerLimitationS "Cannot compile parallel scans with array element type." + + renamed_lam <- renameLambda lam + + acc_local_mem <- flip zip (repeat ()) <$> + mapM (fmap (ImpGen.memLocationName . ImpGen.entryArrayLocation) . + ImpGen.lookupArray) arrs + + let ltid = kernelLocalThreadId constants + (lam_i, other_index_param, actual_params) = + partitionChunkedKernelLambdaParameters $ lambdaParams lam + (x_params, y_params) = splitAt (length arrs) actual_params + + ImpGen.dLParams (lambdaParams lam++lambdaParams renamed_lam) + lam_i <-- ltid + + -- The scan works by splitting the group into blocks, which are + -- scanned separately. Typically, these blocks are smaller than + -- the lockstep width, which enables barrier-free execution inside + -- them. + -- + -- We hardcode the block size here. The only requirement is that + -- it should not be less than the square root of the group size. + -- With 32, we will work on groups of size 1024 or smaller, which + -- fits every device Troels has seen. Still, it would be nicer if + -- it were a runtime parameter. Some day. + let block_size = Imp.ValueExp $ IntValue $ Int32Value 32 + simd_width = kernelWaveSize constants + block_id = ltid `quot` block_size + in_block_id = ltid - block_id * block_size + doInBlockScan seg_flag' active = inBlockScan seg_flag' simd_width block_size active ltid acc_local_mem + ltid_in_bounds = ltid .<. w + + doInBlockScan seg_flag ltid_in_bounds lam + sOp Imp.LocalBarrier + + let last_in_block = in_block_id .==. block_size - 1 + sComment "last thread of block 'i' writes its result to offset 'i'" $ + sWhen (last_in_block .&&. ltid_in_bounds) $ + zipWithM_ (writeParamToLocalMemory block_id) acc_local_mem y_params + + sOp Imp.LocalBarrier + + let is_first_block = block_id .==. 0 + first_block_seg_flag = do + flag_true <- seg_flag + Just $ \from to -> + flag_true (from*block_size+block_size-1) (to*block_size+block_size-1) + ImpGen.comment + "scan the first block, after which offset 'i' contains carry-in for warp 'i+1'" $ + doInBlockScan first_block_seg_flag (is_first_block .&&. ltid_in_bounds) renamed_lam + + sOp Imp.LocalBarrier + + let read_carry_in = + zipWithM_ (readParamFromLocalMemory + (paramName other_index_param) (block_id - 1)) + x_params acc_local_mem + + let op_to_y + | Nothing <- seg_flag = + ImpGen.compileBody' y_params $ lambdaBody lam + | Just flag_true <- seg_flag = + sUnless (flag_true (block_id*block_size-1) ltid) $ + ImpGen.compileBody' y_params $ lambdaBody lam + write_final_result = + zipWithM_ (writeParamToLocalMemory ltid) acc_local_mem y_params + + sComment "carry-in for every block except the first" $ + sUnless (is_first_block .||. Imp.UnOpExp Not ltid_in_bounds) $ do + sComment "read operands" read_carry_in + sComment "perform operation" op_to_y + sComment "write final result" write_final_result + + sOp Imp.LocalBarrier + + sComment "restore correct values for first block" $ + sWhen is_first_block write_final_result + +inBlockScan :: Maybe (Imp.Exp -> Imp.Exp -> Imp.Exp) + -> Imp.Exp + -> Imp.Exp + -> Imp.Exp + -> Imp.Exp + -> [(VName, t)] + -> Lambda InKernel + -> InKernelGen () +inBlockScan seg_flag lockstep_width block_size active ltid acc_local_mem scan_lam = ImpGen.everythingVolatile $ do + skip_threads <- dPrim "skip_threads" int32 + let in_block_thread_active = + Imp.var skip_threads int32 .<=. in_block_id + (scan_lam_i, other_index_param, actual_params) = + partitionChunkedKernelLambdaParameters $ lambdaParams scan_lam + (x_params, y_params) = + splitAt (length actual_params `div` 2) actual_params + read_operands = + zipWithM_ (readParamFromLocalMemory (paramName other_index_param) $ + ltid - Imp.var skip_threads int32) + x_params acc_local_mem + + -- Set initial y values + sWhen active $ + zipWithM_ (readParamFromLocalMemory scan_lam_i ltid) + y_params acc_local_mem + + let op_to_y + | Nothing <- seg_flag = + ImpGen.compileBody' y_params $ lambdaBody scan_lam + | Just flag_true <- seg_flag = + sUnless (flag_true (ltid-Imp.var skip_threads int32) ltid) $ + ImpGen.compileBody' y_params $ lambdaBody scan_lam + write_operation_result = + zipWithM_ (writeParamToLocalMemory ltid) acc_local_mem y_params + maybeLocalBarrier = sWhen (lockstep_width .<=. Imp.var skip_threads int32) $ + sOp Imp.LocalBarrier + + sComment "in-block scan (hopefully no barriers needed)" $ do + skip_threads <-- 1 + sWhile (Imp.var skip_threads int32 .<. block_size) $ do + sWhen (in_block_thread_active .&&. active) $ do + sComment "read operands" read_operands + sComment "perform operation" op_to_y + + maybeLocalBarrier + + sWhen (in_block_thread_active .&&. active) $ + sComment "write result" write_operation_result + + maybeLocalBarrier + + skip_threads <-- Imp.var skip_threads int32 * 2 + + where block_id = ltid `quot` block_size + in_block_id = ltid - block_id * block_size + +compileKernelStms :: KernelConstants -> [Stm InKernel] + -> InKernelGen a + -> InKernelGen a +compileKernelStms constants ungrouped_bnds m = + compileGroupedKernelStms' $ groupStmsByGuard constants ungrouped_bnds + where compileGroupedKernelStms' [] = m + compileGroupedKernelStms' ((g, bnds):rest_bnds) = do + ImpGen.dScopes (map ((Just . stmExp) &&& (castScope . scopeOf)) bnds) + protect g $ mapM_ compileKernelStm bnds + compileGroupedKernelStms' rest_bnds + + protect Nothing body_m = + body_m + protect (Just (Imp.ValueExp (BoolValue True))) body_m = + body_m + protect (Just g) body_m = + sWhen g $ allThreads constants body_m + + compileKernelStm (Let pat _ e) = ImpGen.compileExp pat e + +groupStmsByGuard :: KernelConstants + -> [Stm InKernel] + -> [(Maybe Imp.Exp, [Stm InKernel])] +groupStmsByGuard constants bnds = + map collapse $ groupBy sameGuard $ zip (map bindingGuard bnds) bnds + where bindingGuard (Let _ _ Op{}) = Nothing + bindingGuard _ = Just $ kernelThreadActive constants + + sameGuard (g1, _) (g2, _) = g1 == g2 + + collapse [] = + (Nothing, []) + collapse l@((g,_):_) = + (g, map snd l) + +sKernel :: KernelConstants -> String -> ImpGen.ImpM InKernel Imp.KernelOp a -> CallKernelGen () +sKernel constants name m = do + body <- makeAllMemoryGlobal $ + ImpGen.subImpM_ (inKernelOperations constants) m + (uses, local_memory) <- computeKernelUses body mempty + ImpGen.emit $ Imp.Op $ Imp.CallKernel Imp.Kernel + { Imp.kernelBody = body + , Imp.kernelLocalMemory = local_memory + , Imp.kernelUses = uses + , Imp.kernelNumGroups = [kernelNumGroups constants] + , Imp.kernelGroupSize = [kernelGroupSize constants] + , Imp.kernelName = + nameFromString $ name ++ "_" ++ show (baseTag $ kernelGlobalThreadIdVar constants) + } diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs @@ -0,0 +1,601 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +-- | We generate code for non-segmented/single-segment SegRed using +-- the basic approach outlined in the paper "Design and GPGPU +-- Performance of Futhark’s Redomap Construct" (ARRAY '16). The main +-- deviations are: +-- +-- * While we still use two-phase reduction, we use only a single +-- kernel, with the final workgroup to write a result (tracked via +-- an atomic counter) performing the final reduction as well. +-- +-- * Instead of depending on storage layout transformations to handle +-- non-commutative reductions efficiently, we slide a +-- 'groupsize'-sized window over the input, and perform a parallel +-- reduction for each window. This sacrifices the notion of +-- efficient sequentialisation, but is sometimes faster and +-- definitely simpler and more predictable (and uses less auxiliary +-- storage). +-- +-- For segmented reductions we use the approach from "Strategies for +-- Regular Segmented Reductions on GPU" (FHPC '17). This involves +-- having two different strategies, and dynamically deciding which one +-- to use based on the number of segments and segment size. We use the +-- (static) @group_size@ to decide which of the following two +-- strategies to choose: +-- +-- * Large: uses one or more groups to process a single segment. If +-- multiple groups are used per segment, the intermediate reduction +-- results must be recursively reduced, until there is only a single +-- value per segment. +-- +-- Each thread /can/ read multiple elements, which will greatly +-- increase performance; however, if the reduction is +-- non-commutative we will have to use a less efficient traversal +-- (with interim group-wide reductions) to enable coalesced memory +-- accesses, just as in the non-segmented case. +-- +-- * Small: is used to let each group process *multiple* segments +-- within a group. We will only use this approach when we can +-- process at least two segments within a single group. In those +-- cases, we would allocate a /whole/ group per segment with the +-- large strategy, but at most 50% of the threads in the group would +-- have any element to read, which becomes highly inefficient. +module Futhark.CodeGen.ImpGen.Kernels.SegRed + ( compileSegRed + ) + where + +import Control.Monad.Except +import Data.Maybe +import qualified Data.Set as S +import Data.List + +import Prelude hiding (quot, rem) + +import Futhark.MonadFreshNames +import Futhark.Transform.Rename +import Futhark.Representation.ExplicitMemory +import qualified Futhark.CodeGen.ImpCode.Kernels as Imp +import qualified Futhark.CodeGen.ImpGen as ImpGen +import Futhark.CodeGen.ImpGen ((<--), + sFor, sComment, sIf, sWhen, + sOp, + dPrim, dPrimV) +import Futhark.CodeGen.ImpGen.Kernels.Base +import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun +import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) + +-- | For many kernels, we may not have enough physical groups to cover +-- the logical iteration space. Some groups thus have to perform +-- double duty; we put an outer loop to accomplish this. The +-- advantage over just launching a bazillion threads is that the cost +-- of memory expansion should be proportional to the number of +-- *physical* threads (hardware parallelism), not the amount of +-- application parallelism. +virtualiseGroups :: KernelConstants + -> Imp.Exp + -> (Imp.Exp -> ImpGen.ImpM lore op ()) + -> ImpGen.ImpM lore op () +virtualiseGroups constants required_groups m = do + let group_id = kernelGroupId constants + iterations = (required_groups - group_id) `quotRoundingUp` kernelNumGroups constants + i <- newVName "i" + sFor i Int32 iterations $ m $ group_id + Imp.var i int32 * kernelNumGroups constants + +-- Compile 'SegRed' instance to host-level code with calls to various +-- kernels. +compileSegRed :: Pattern ExplicitMemory + -> KernelSpace + -> Commutativity -> Lambda InKernel -> [SubExp] + -> Body InKernel + -> CallKernelGen () +compileSegRed pat space comm red_op nes body + | [(_, Constant (IntValue (Int32Value 1))), _] <- spaceDimensions space = + nonsegmentedReduction pat space comm red_op nes body + | otherwise = do + segment_size <- + ImpGen.compileSubExp $ last $ map snd $ spaceDimensions space + group_size <- ImpGen.compileSubExp $ spaceGroupSize space + let use_small_segments = segment_size * 2 .<. group_size + sIf (segment_size .==. 1) + (unitSegmentsReduction pat space nes body) $ + sIf use_small_segments + (smallSegmentsReduction pat space red_op nes body) + (largeSegmentsReduction pat space comm red_op nes body) + +-- Handle degenerate case where segments are of size 1, meaning +-- that it is really just a 'map' in disguise. +unitSegmentsReduction :: Pattern ExplicitMemory + -> KernelSpace + -> [SubExp] + -> Body InKernel + -> CallKernelGen () +unitSegmentsReduction (Pattern _ segred_pes) space nes body = do + (constants, init_constants) <- kernelInitialisationSetSpace space $ return () + + let (gtids, dims) = unzip $ spaceDimensions space + (redout_pes, mapout_pes) = splitAt (length nes) segred_pes + + dims' <- mapM ImpGen.compileSubExp dims + + let num_segments = product $ init dims' + required_groups = num_segments `quotRoundingUp` kernelGroupSize constants + + ImpGen.emit $ Imp.DebugPrint "num_segments" int32 num_segments + ImpGen.emit $ Imp.DebugPrint "required_groups" int32 required_groups + + sKernel constants "segred_mapseg" $ do + init_constants + virtualiseGroups constants required_groups $ \group_id -> do + setSpaceIndices (group_id * kernelGroupSize constants + kernelLocalThreadId constants) space + ImpGen.compileStms mempty (stmsToList $ bodyStms body) $ + sWhen (kernelThreadActive constants) $ do + let (redout_ses, mapout_ses) = splitAt (length nes) $ bodyResult body + forM_ (zip redout_pes redout_ses) $ \(pe, se) -> + ImpGen.copyDWIM (patElemName pe) + (map (`Imp.var` int32) (init gtids)) se [] + + forM_ (zip mapout_pes mapout_ses) $ \(pe, se) -> + ImpGen.copyDWIM (patElemName pe) + (map (`Imp.var` int32) gtids) se [] + +nonsegmentedReduction :: Pattern ExplicitMemory + -> KernelSpace + -> Commutativity -> Lambda InKernel -> [SubExp] + -> Body InKernel + -> CallKernelGen () +nonsegmentedReduction segred_pat space comm red_op nes body = do + (base_constants, init_constants) <- kernelInitialisationSetSpace space $ return () + let constants = base_constants { kernelThreadActive = true } + global_tid = kernelGlobalThreadId constants + (_, w) = last $ spaceDimensions space + + let red_op_params = lambdaParams red_op + (red_acc_params, _) = splitAt (length nes) red_op_params + red_arrs <- forM red_acc_params $ \p -> + case paramAttr p of + MemArray pt shape _ (ArrayIn mem _) -> do + let shape' = Shape [spaceNumThreads space] <> shape + ImpGen.sArray "red_arr" pt shape' $ + ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape' + _ -> do + let pt = elemType $ paramType p + shape = Shape [spaceGroupSize space] + ImpGen.sAllocArray "red_arr" pt shape $ Space "local" + + counter <- + ImpGen.sStaticArray "counter" (Space "device") int32 $ + replicate 1 $ IntValue $ Int32Value 0 + + group_res_arrs <- forM (lambdaReturnType red_op) $ \t -> do + let pt = elemType t + shape = Shape [spaceNumGroups space] <> arrayShape t + ImpGen.sAllocArray "group_res_arr" pt shape $ Space "device" + + sync_arr <- ImpGen.sAllocArray "sync_arr" Bool (Shape [intConst Int32 1]) $ Space "local" + + num_threads <- dPrimV "num_threads" $ kernelNumThreads constants + + sKernel constants "segred_nonseg" $ allThreads constants $ do + init_constants + + -- Since this is the nonsegmented case, all outer segment IDs must + -- necessarily be 0. + let gtids = map fst $ spaceDimensions space + forM_ (init gtids) $ \v -> + v <-- 0 + + num_elements <- Imp.elements <$> ImpGen.compileSubExp w + let elems_per_thread = num_elements `quotRoundingUp` Imp.elements (kernelNumThreads constants) + + (group_result_params, red_op_renamed) <- + reductionStageOne constants segred_pat num_elements + global_tid elems_per_thread num_threads + comm red_op nes red_arrs body + + reductionStageTwo constants segred_pat 0 [0] 0 + (kernelNumGroups constants) group_result_params red_acc_params red_op_renamed nes + 1 counter sync_arr group_res_arrs red_arrs + +hasMemoryAccesses :: Body InKernel -> ImpGen.ImpM InKernel Imp.KernelOp Bool +hasMemoryAccesses body = or <$> mapM isArray (S.toList $ freeInBody body) + where isArray = fmap (not . primType) . lookupType + +smallSegmentsReduction :: Pattern ExplicitMemory + -> KernelSpace + -> Lambda InKernel -> [SubExp] + -> Body InKernel + -> CallKernelGen () +smallSegmentsReduction (Pattern _ segred_pes) space red_op nes body = do + (base_constants, init_constants) <- kernelInitialisationSetSpace space $ return () + let constants = base_constants { kernelThreadActive = true } + + let (gtids, dims) = unzip $ spaceDimensions space + dims' <- mapM ImpGen.compileSubExp dims + + let segment_size = last dims' + num_segments = product $ init dims' + segments_per_group = kernelGroupSize constants `quot` segment_size + required_groups = num_segments `quotRoundingUp` segments_per_group + + let red_op_params = lambdaParams red_op + (red_acc_params, _red_next_params) = splitAt (length nes) red_op_params + red_arrs <- forM red_acc_params $ \p -> + case paramAttr p of + MemArray pt shape _ (ArrayIn mem _) -> do + let shape' = Shape [spaceNumThreads space] <> shape + ImpGen.sArray "red_arr" pt shape' $ + ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape' + _ -> do + let pt = elemType $ paramType p + shape = Shape [spaceGroupSize space] + ImpGen.sAllocArray "red_arr" pt shape $ Space "local" + + ImpGen.emit $ Imp.DebugPrint "num_segments" int32 num_segments + ImpGen.emit $ Imp.DebugPrint "segment_size" int32 segment_size + ImpGen.emit $ Imp.DebugPrint "segments_per_group" int32 segments_per_group + ImpGen.emit $ Imp.DebugPrint "required_groups" int32 required_groups + + sKernel constants "segred_small" $ allThreads constants $ do + init_constants + + -- We probably do not have enough actual workgroups to cover the + -- entire iteration space. Some groups thus have to perform double + -- duty; we put an outer loop to accomplish this. + virtualiseGroups constants required_groups $ \group_id' -> do + -- Compute the 'n' input indices. The outer 'n-1' correspond to + -- the segment ID, and are computed from the group id. The inner + -- is computed from the local thread id, and may be out-of-bounds. + let ltid = kernelLocalThreadId constants + segment_index = (ltid `quot` segment_size) + (group_id' * segments_per_group) + index_within_segment = ltid `rem` segment_size + + zipWithM_ (<--) (init gtids) $ unflattenIndex (init dims') segment_index + last gtids <-- index_within_segment + + let toLocalMemory ses = + forM_ (zip red_arrs ses) $ \(arr, se) -> do + se_t <- subExpType se + when (primType se_t) $ + ImpGen.copyDWIM arr [ltid] se [] + + in_bounds = + ImpGen.compileStms mempty (stmsToList $ bodyStms body) $ do + let (red_res, map_res) = splitAt (length nes) $ bodyResult body + + sComment "save results to be reduced" $ + toLocalMemory red_res + + sComment "save map-out results" $ + forM_ (zip (drop (length nes) segred_pes) map_res) $ \(pe, se) -> + ImpGen.copyDWIM (patElemName pe) (map (`Imp.var` int32) gtids) se [] + + sComment "apply map function if in bounds" $ + sIf (isActive (init $ zip gtids dims) .&&. + ltid .<. segment_size * segments_per_group) in_bounds (toLocalMemory nes) + + sOp Imp.LocalBarrier + + index_i <- newVName "index_i" + index_j <- newVName "index_j" + let crossesSegment from to = + (to-from) .>. (to `rem` segment_size) + red_op' = red_op { lambdaParams = Param index_i (MemPrim int32) : + Param index_j (MemPrim int32) : + lambdaParams red_op } + + sComment "perform segmented scan to imitate reduction" $ + groupScan constants (Just crossesSegment) (segment_size*segments_per_group) red_op' red_arrs + + sOp Imp.LocalBarrier + + sComment "save final values of segments" $ + sWhen (group_id' * segments_per_group + ltid .<. num_segments .&&. + ltid .<. segments_per_group) $ + forM_ (zip segred_pes red_arrs) $ \(pe, arr) -> do + -- Figure out which segment result this thread should write... + let flat_segment_index = group_id' * segments_per_group + ltid + gtids' = unflattenIndex (init dims') flat_segment_index + ImpGen.copyDWIM (patElemName pe) gtids' + (Var arr) [(ltid+1) * segment_size - 1] + +largeSegmentsReduction :: Pattern ExplicitMemory + -> KernelSpace + -> Commutativity -> Lambda InKernel -> [SubExp] + -> Body InKernel + -> CallKernelGen () +largeSegmentsReduction segred_pat space comm red_op nes body = do + (base_constants, init_constants) <- kernelInitialisationSetSpace space $ return () + let (gtids, dims) = unzip $ spaceDimensions space + dims' <- mapM ImpGen.compileSubExp dims + let segment_size = last dims' + num_segments = product $ init dims' + + let (groups_per_segment, elems_per_thread) = + groupsPerSegmentAndElementsPerThread segment_size num_segments + (kernelNumGroups base_constants) (kernelGroupSize base_constants) + num_groups <- dPrimV "num_groups" $ + groups_per_segment * num_segments + + num_threads <- dPrimV "num_threads" $ + Imp.var num_groups int32 * kernelGroupSize base_constants + + threads_per_segment <- dPrimV "thread_per_segment" $ + groups_per_segment * kernelGroupSize base_constants + + let constants = base_constants + { kernelThreadActive = true + , kernelNumGroups = Imp.var num_groups int32 + , kernelNumThreads = Imp.var num_threads int32 + } + + ImpGen.emit $ Imp.DebugPrint "num_segments" int32 num_segments + ImpGen.emit $ Imp.DebugPrint "segment_size" int32 segment_size + ImpGen.emit $ Imp.DebugPrint "num_groups" int32 (Imp.var num_groups int32) + ImpGen.emit $ Imp.DebugPrint "group_size" int32 (kernelGroupSize constants) + ImpGen.emit $ Imp.DebugPrint "elems_per_thread" int32 $ Imp.innerExp elems_per_thread + ImpGen.emit $ Imp.DebugPrint "groups_per_segment" int32 groups_per_segment + + let red_op_params = lambdaParams red_op + (red_acc_params, _) = splitAt (length nes) red_op_params + red_arrs <- forM red_acc_params $ \p -> + case paramAttr p of + MemArray pt shape _ (ArrayIn mem _) -> do + let shape' = Shape [Var num_threads] <> shape + ImpGen.sArray "red_arr" pt shape' $ + ArrayIn mem $ IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape' + _ -> do + let pt = elemType $ paramType p + shape = Shape [spaceGroupSize space] + ImpGen.sAllocArray "red_arr" pt shape $ Space "local" + + group_res_arrs <- forM (lambdaReturnType red_op) $ \t -> do + let pt = elemType t + shape = Shape [Var num_groups] <> arrayShape t + ImpGen.sAllocArray "group_res_arr" pt shape $ Space "device" + + -- In principle we should have a counter for every segment. Since + -- the number of segments is a dynamic quantity, we would have to + -- allocate and zero out an array here, which is expensive. + -- However, we exploit the fact that the number of segments being + -- reduced at any point in time is limited by the number of + -- workgroups. If we bound the number of workgroups, we can get away + -- with using that many counters. FIXME: Is this limit checked + -- anywhere? There are other places in the compiler that will fail + -- if the group count exceeds the maximum group size, which is at + -- most 1024 anyway. + let num_counters = 1024 + counter <- + ImpGen.sStaticArray "counter" (Space "device") int32 $ + replicate num_counters $ IntValue $ Int32Value 0 + + sync_arr <- ImpGen.sAllocArray "sync_arr" Bool (Shape [intConst Int32 1]) $ Space "local" + + sKernel constants "segred_large" $ allThreads constants $ do + init_constants + let segment_gtids = init gtids + group_id = kernelGroupId constants + group_size = kernelGroupSize constants + flat_segment_id = group_id `quot` groups_per_segment + local_tid = kernelLocalThreadId constants + + global_tid = kernelGlobalThreadId constants + `rem` (group_size * groups_per_segment) + w = last dims + first_group_for_segment = flat_segment_id * groups_per_segment + + zipWithM_ (<--) segment_gtids $ unflattenIndex (init dims') flat_segment_id + num_elements <- Imp.elements <$> ImpGen.compileSubExp w + + (group_result_params, red_op_renamed) <- + reductionStageOne constants segred_pat num_elements + global_tid elems_per_thread threads_per_segment + comm red_op nes red_arrs body + + let multiple_groups_per_segment = + reductionStageTwo constants segred_pat + flat_segment_id (map (`Imp.var` int32) segment_gtids) + first_group_for_segment groups_per_segment + group_result_params red_acc_params red_op_renamed + nes (fromIntegral num_counters) counter sync_arr group_res_arrs red_arrs + + one_group_per_segment = + ImpGen.comment "first thread in group saves final result to memory" $ + sWhen (local_tid .==. 0) $ + forM_ (take (length nes) $ zip (patternNames segred_pat) group_result_params) $ \(v, p) -> + ImpGen.copyDWIM v (map (`Imp.var` int32) segment_gtids) (Var $ paramName p) [] + + sIf (groups_per_segment .==. 1) one_group_per_segment multiple_groups_per_segment + +groupsPerSegmentAndElementsPerThread :: Imp.Exp -> Imp.Exp -> Imp.Exp -> Imp.Exp + -> (Imp.Exp, Imp.Count Imp.Elements) +groupsPerSegmentAndElementsPerThread segment_size num_segments num_groups_hint group_size = + let groups_per_segment = + num_groups_hint `quotRoundingUp` num_segments + elements_per_thread = + segment_size `quotRoundingUp` (group_size * groups_per_segment) + in (groups_per_segment, Imp.elements elements_per_thread) + +reductionStageOne :: KernelConstants + -> Pattern ExplicitMemory + -> Imp.Count Imp.Elements + -> Imp.Exp + -> Imp.Count Imp.Elements + -> VName + -> Commutativity + -> LambdaT InKernel + -> [SubExp] + -> [VName] + -> Body InKernel + -> InKernelGen ([LParam InKernel], Lambda InKernel) +reductionStageOne constants (Pattern _ segred_pes) num_elements global_tid elems_per_thread threads_per_segment comm red_op nes red_arrs body = do + + let red_op_params = lambdaParams red_op + (red_acc_params, red_next_params) = splitAt (length nes) red_op_params + (gtids, _dims) = unzip $ kernelDimensions constants + gtid = last gtids + local_tid = kernelLocalThreadId constants + index_in_segment = global_tid `quot` kernelGroupSize constants + + -- Figure out how many elements this thread should process. + chunk_size <- dPrim "chunk_size" int32 + let ordering = case comm of Commutative -> SplitStrided $ Var threads_per_segment + Noncommutative -> SplitContiguous + accesses_memory <- hasMemoryAccesses body + computeThreadChunkSize ordering global_tid elems_per_thread num_elements chunk_size + + ImpGen.dScope Nothing $ scopeOfLParams $ lambdaParams red_op + + forM_ (zip red_acc_params nes) $ \(p, ne) -> + ImpGen.copyDWIM (paramName p) [] ne [] + + red_op_renamed <- renameLambda red_op + + let doTheReduction = do + ImpGen.comment "to reduce current chunk, first store our result to memory" $ + forM_ (zip red_arrs red_acc_params) $ \(arr, p) -> + when (primType $ paramType p) $ + ImpGen.copyDWIM arr [local_tid] (Var $ paramName p) [] + + sOp Imp.LocalBarrier + + groupReduce constants (kernelGroupSize constants) red_op_renamed red_arrs + + 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. + let (bound, check_bounds) = + case comm of + Commutative -> (Imp.var chunk_size int32, id) + Noncommutative -> (Imp.innerExp elems_per_thread, + sWhen (Imp.var gtid int32 .<. Imp.innerExp num_elements)) + + sFor i Int32 bound $ do + gtid <-- + case comm of + Commutative -> + global_tid + + Imp.var threads_per_segment int32 * Imp.var i int32 + Noncommutative | accesses_memory -> + local_tid + + (index_in_segment * Imp.innerExp elems_per_thread + Imp.var i int32) * + kernelGroupSize constants + Noncommutative -> + Imp.var i int32 + + global_tid * Imp.innerExp elems_per_thread + + check_bounds $ sComment "apply map function" $ + ImpGen.compileStms mempty (stmsToList $ bodyStms body) $ do + let (red_res, map_res) = splitAt (length nes) $ bodyResult body + + sComment "save results to be reduced" $ + forM_ (zip red_next_params red_res) $ \(p, se) -> + ImpGen.copyDWIM (paramName p) [] se [] + + sComment "save map-out results" $ + forM_ (zip (drop (length nes) segred_pes) map_res) $ \(pe, se) -> + ImpGen.copyDWIM (patElemName pe) (map (`Imp.var` int32) gtids) se [] + + sComment "apply reduction operator" $ + ImpGen.compileBody' red_acc_params $ lambdaBody red_op + + case comm of + Noncommutative | accesses_memory -> do + doTheReduction + sComment "first thread takes carry-out; others neutral element" $ do + let carry_out = + forM_ (zip red_acc_params $ lambdaParams red_op_renamed) $ \(p_to, p_from) -> + ImpGen.copyDWIM (paramName p_to) [] (Var $ paramName p_from) [] + reset_to_neutral = + forM_ (zip red_acc_params nes) $ \(p, ne) -> + ImpGen.copyDWIM (paramName p) [] ne [] + sIf (local_tid .==. 0) carry_out reset_to_neutral + _ -> + return () + + group_result_params <- case comm of + Noncommutative | accesses_memory -> + return red_acc_params + + _ -> do + doTheReduction + + return $ lambdaParams red_op_renamed + + return (group_result_params, red_op_renamed) + +reductionStageTwo :: KernelConstants + -> Pattern ExplicitMemory + -> Imp.Exp + -> [Imp.Exp] + -> Imp.Exp + -> PrimExp Imp.ExpLeaf + -> [LParam InKernel] + -> [LParam InKernel] + -> Lambda InKernel + -> [SubExp] + -> Imp.Exp + -> VName + -> VName + -> [VName] + -> [VName] + -> InKernelGen () +reductionStageTwo constants segred_pat + flat_segment_id segment_gtids first_group_for_segment groups_per_segment + group_result_params red_acc_params + red_op_renamed nes + num_counters counter sync_arr group_res_arrs red_arrs = do + let local_tid = kernelLocalThreadId constants + group_id = kernelGroupId constants + group_size = kernelGroupSize constants + old_counter <- dPrim "old_counter" int32 + (counter_mem, _, counter_offset) <- ImpGen.fullyIndexArray counter [flat_segment_id `rem` num_counters] + ImpGen.comment "first thread in group saves group result to memory" $ + sWhen (local_tid .==. 0) $ do + forM_ (take (length nes) $ zip group_res_arrs group_result_params) $ \(v, p) -> + ImpGen.copyDWIM v [group_id] (Var $ paramName p) [] + sOp Imp.MemFence + -- Increment the counter, thus stating that our result is + -- available. + sOp $ Imp.Atomic $ Imp.AtomicAdd old_counter counter_mem counter_offset 1 + -- Now check if we were the last group to write our result. If + -- so, it is our responsibility to produce the final result. + ImpGen.sWrite sync_arr [0] $ Imp.var old_counter int32 .==. groups_per_segment - 1 + + sOp Imp.LocalBarrier + + is_last_group <- dPrim "is_last_group" Bool + ImpGen.copyDWIM is_last_group [] (Var sync_arr) [0] + sWhen (Imp.var is_last_group Bool) $ do + -- The final group has written its result (and it was + -- us!), so read in all the group results and perform the + -- final stage of the reduction. But first, we reset the + -- counter so it is ready for next time. This is done + -- with an atomic to avoid warnings about write/write + -- races in oclgrind. + sWhen (local_tid .==. 0) $ + sOp $ Imp.Atomic $ Imp.AtomicAdd old_counter counter_mem counter_offset $ + negate groups_per_segment + ImpGen.comment "read in the per-group-results" $ + forM_ (zip4 red_acc_params red_arrs nes group_res_arrs) $ + \(p, arr, ne, group_res_arr) -> do + let load_group_result = + ImpGen.copyDWIM (paramName p) [] + (Var group_res_arr) [first_group_for_segment + local_tid] + load_neutral_element = + ImpGen.copyDWIM (paramName p) [] ne [] + ImpGen.sIf (local_tid .<. groups_per_segment) + load_group_result load_neutral_element + when (primType $ paramType p) $ + ImpGen.copyDWIM arr [local_tid] (Var $ paramName p) [] + + sComment "reduce the per-group results" $ do + groupReduce constants group_size red_op_renamed red_arrs + + sComment "and back to memory with the final result" $ + sWhen (local_tid .==. 0) $ + forM_ (take (length nes) $ zip (patternNames segred_pat) $ + lambdaParams red_op_renamed) $ \(v, p) -> + ImpGen.copyDWIM v segment_gtids (Var $ paramName p) [] 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 @@ -4,6 +4,7 @@ -- kernels to imperative code with OpenCL calls. module Futhark.CodeGen.ImpGen.Kernels.ToOpenCL ( kernelsToOpenCL + , kernelsToCUDA ) where @@ -14,10 +15,10 @@ import Data.Maybe import qualified Data.Set as S import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import qualified Language.C.Syntax as C import qualified Language.C.Quote.OpenCL as C +import qualified Language.C.Quote.CUDA as CUDAC import Futhark.Error import qualified Futhark.CodeGen.Backends.GenericC as GenericC @@ -30,19 +31,27 @@ import Futhark.Util (zEncodeString) import Futhark.Util.Pretty (pretty, prettyOneLine) +kernelsToCUDA, kernelsToOpenCL :: ImpKernels.Program + -> Either InternalError ImpOpenCL.Program +kernelsToCUDA = translateKernels TargetCUDA +kernelsToOpenCL = translateKernels TargetOpenCL + -- | Translate a kernels-program to an OpenCL-program. -kernelsToOpenCL :: ImpKernels.Program - -> Either InternalError ImpOpenCL.Program -kernelsToOpenCL (ImpKernels.Functions funs) = do +translateKernels :: KernelTarget + -> ImpKernels.Program + -> Either InternalError ImpOpenCL.Program +translateKernels target (ImpKernels.Functions funs) = do (prog', ToOpenCL extra_funs kernels requirements sizes) <- runWriterT $ fmap Functions $ forM funs $ \(fname, fun) -> - (fname,) <$> runReaderT (traverse onHostOp fun) fname + (fname,) <$> runReaderT (traverse (onHostOp target) fun) fname let kernel_names = M.keys kernels opencl_code = openClCode $ M.elems kernels - opencl_prelude = pretty $ genOpenClPrelude requirements + opencl_prelude = pretty $ genPrelude target requirements return $ ImpOpenCL.Program opencl_code opencl_prelude kernel_names (S.toList $ kernelUsedTypes requirements) sizes $ ImpOpenCL.Functions (M.toList extra_funs) <> prog' + where genPrelude TargetOpenCL = genOpenClPrelude + genPrelude TargetCUDA = genCUDAPrelude pointerQuals :: Monad m => String -> m [C.TypeQual] pointerQuals "global" = return [C.ctyquals|__global|] @@ -61,75 +70,42 @@ , _kernelConstants :: [(VName, KernelConstExp)] } -instance Sem.Semigroup OpenClRequirements where +instance Semigroup OpenClRequirements where OpenClRequirements ts1 consts1 <> OpenClRequirements ts2 consts2 = OpenClRequirements (ts1 <> ts2) (consts1 <> consts2) instance Monoid OpenClRequirements where mempty = OpenClRequirements mempty mempty - mappend = (Sem.<>) data ToOpenCL = ToOpenCL { clExtraFuns :: M.Map Name ImpOpenCL.Function , clKernels :: M.Map KernelName C.Func , clRequirements :: OpenClRequirements - , clSizes :: M.Map VName (SizeClass, Name) + , clSizes :: M.Map Name SizeClass } -instance Sem.Semigroup ToOpenCL where +instance Semigroup ToOpenCL where ToOpenCL f1 k1 r1 sz1 <> ToOpenCL f2 k2 r2 sz2 = ToOpenCL (f1<>f2) (k1<>k2) (r1<>r2) (sz1<>sz2) instance Monoid ToOpenCL where mempty = ToOpenCL mempty mempty mempty mempty - mappend = (Sem.<>) type OnKernelM = ReaderT Name (WriterT ToOpenCL (Either InternalError)) -onHostOp :: HostOp -> OnKernelM OpenCL -onHostOp (CallKernel k) = onKernel k -onHostOp (ImpKernels.GetSize v key size_class) = do - fname <- ask - tell mempty { clSizes = M.singleton key (size_class, fname) } +onHostOp :: KernelTarget -> HostOp -> OnKernelM OpenCL +onHostOp target (CallKernel k) = onKernel target k +onHostOp _ (ImpKernels.GetSize v key size_class) = do + tell mempty { clSizes = M.singleton key size_class } return $ ImpOpenCL.GetSize v key -onHostOp (ImpKernels.CmpSizeLe v key size_class x) = do - fname <- ask - tell mempty { clSizes = M.singleton key (size_class, fname) } +onHostOp _ (ImpKernels.CmpSizeLe v key size_class x) = do + tell mempty { clSizes = M.singleton key size_class } return $ ImpOpenCL.CmpSizeLe v key x -onHostOp (ImpKernels.GetSizeMax v size_class) = +onHostOp _ (ImpKernels.GetSizeMax v size_class) = return $ ImpOpenCL.GetSizeMax v size_class -onKernel :: CallKernel -> OnKernelM OpenCL - -onKernel called@(Map kernel) = do - let (funbody, _) = - GenericC.runCompilerM (Functions []) inKernelOperations blankNameSource mempty $ do - size <- GenericC.compileExp $ mapKernelSize kernel - let check = [C.citem|if ($id:(mapKernelThreadNum kernel) >= $exp:size) return;|] - body <- GenericC.blockScope $ GenericC.compileCode $ mapKernelBody kernel - return $ check : body - - params = mapMaybe useAsParam $ mapKernelUses kernel - - tell mempty - { clExtraFuns = mempty - , clKernels = M.singleton (mapKernelName kernel) - [C.cfun|__kernel void $id:(mapKernelName kernel) ($params:params) { - const uint $id:(mapKernelThreadNum kernel) = get_global_id(0); - $items:funbody - }|] - , clRequirements = OpenClRequirements - (typesInKernel called) - (mapMaybe useAsConst $ mapKernelUses kernel) - } - - return $ LaunchKernel - (calledKernelName called) (kernelArgs called) kernel_size workgroup_size - - where kernel_size = [sizeToExp (mapKernelNumGroups kernel) * - sizeToExp (mapKernelGroupSize kernel)] - workgroup_size = [sizeToExp $ mapKernelGroupSize kernel] +onKernel :: KernelTarget -> Kernel -> OnKernelM OpenCL -onKernel called@(AnyKernel kernel) = do +onKernel target kernel = do let (kernel_body, _) = GenericC.runCompilerM (Functions []) inKernelOperations blankNameSource mempty $ GenericC.blockScope $ GenericC.compileCode $ kernelBody kernel @@ -139,35 +115,64 @@ (local_memory_params, local_memory_init) = unzip $ flip evalState (blankNameSource :: VNameSource) $ - mapM prepareLocalMemory $ kernelLocalMemory kernel + mapM (prepareLocalMemory target) $ kernelLocalMemory kernel - params = catMaybes local_memory_params ++ use_params + -- CUDA has very strict restrictions on the number of blocks + -- permitted along the 'y' and 'z' dimensions of the grid + -- (1<<16). To work around this, we are going to dynamically + -- permute the block dimensions to move the largest one to the + -- 'x' dimension, which has a higher limit (1<<31). This means + -- we need to extend the kernel with extra parameters that + -- contain information about this permutation, but we only do + -- this for multidimensional kernels (at the time of this + -- writing, only transposes). The corresponding arguments are + -- added automatically in CCUDA.hs. + (perm_params, block_dim_init) = + case (target, num_groups) of + (TargetCUDA, [_, _, _]) -> ([[C.cparam|const int block_dim0|], + [C.cparam|const int block_dim1|], + [C.cparam|const int block_dim2|]], + mempty) + _ -> (mempty, + [[C.citem|const int block_dim0 = 0;|], + [C.citem|const int block_dim1 = 1;|], + [C.citem|const int block_dim2 = 2;|]]) + params = perm_params ++ catMaybes local_memory_params ++ use_params + tell mempty { clExtraFuns = mempty - , clKernels = M.singleton name - [C.cfun|__kernel void $id:name ($params:params) { - $items:local_memory_init - $items:kernel_body - }|] - , clRequirements = OpenClRequirements - (typesInKernel called) - (mapMaybe useAsConst $ kernelUses kernel) - } + , clKernels = M.singleton name + [C.cfun|__kernel void $id:name ($params:params) { + $items:block_dim_init + $items:local_memory_init + $items:kernel_body + }|] + , clRequirements = OpenClRequirements + (typesInKernel kernel) + (mapMaybe useAsConst $ kernelUses kernel) + } - return $ LaunchKernel - (calledKernelName called) (kernelArgs called) kernel_size workgroup_size + return $ LaunchKernel name (kernelArgs kernel) num_groups group_size + where name = nameToString $ kernelName kernel + num_groups = kernelNumGroups kernel + group_size = kernelGroupSize kernel - where prepareLocalMemory (mem, Left _) = do + prepareLocalMemory TargetOpenCL (mem, Left _) = do mem_aligned <- newVName $ baseString mem ++ "_aligned" return (Just [C.cparam|__local volatile typename int64_t* $id:mem_aligned|], [C.citem|__local volatile char* restrict $id:mem = $id:mem_aligned;|]) - prepareLocalMemory (mem, Right size) = do + prepareLocalMemory TargetOpenCL (mem, Right size) = do let size' = compilePrimExp size return (Nothing, [C.citem|ALIGNED_LOCAL_MEMORY($id:mem, $exp:size');|]) - name = calledKernelName called - kernel_size = zipWith (*) (kernelNumGroups kernel) (kernelGroupSize kernel) - workgroup_size = kernelGroupSize kernel + prepareLocalMemory TargetCUDA (mem, Left _) = do + param <- newVName $ baseString mem ++ "_offset" + return (Just [C.cparam|uint $id:param|], + [C.citem|volatile char *$id:mem = &shared_mem[$id:param];|]) + prepareLocalMemory TargetCUDA (mem, Right size) = do + let size' = compilePrimExp size + return (Nothing, + [CUDAC.citem|__shared__ volatile char $id:mem[$exp:size'];|]) useAsParam :: KernelUse -> Maybe C.Param useAsParam (ScalarUse name bt) = @@ -222,28 +227,154 @@ (if uses_float64 then cFloat64Ops ++ cFloat64Funs ++ cFloatConvOps else []) ++ [ [C.cedecl|$esc:def|] | def <- map constToDefine consts ] where uses_float64 = FloatType Float64 `S.member` ts - constToDefine (name, e) = - let e' = compilePrimExp e - in unwords ["#define", zEncodeString (pretty name), "("++prettyOneLine e'++")"] -compilePrimExp :: PrimExp KernelConst -> C.Exp -compilePrimExp e = runIdentity $ GenericC.compilePrimExp compileKernelConst e - where compileKernelConst (SizeConst key) = return [C.cexp|$id:(pretty key)|] -mapKernelName :: MapKernel -> String -mapKernelName k = "kernel_"++ mapKernelDesc k ++ "_" ++ - show (baseTag $ mapKernelThreadNum k) +cudaAtomicOps :: [C.Definition] +cudaAtomicOps = (return mkOp <*> opNames <*> types) ++ extraOps + where + mkOp (clName, cuName) t = + [C.cedecl|static inline $ty:t $id:clName(volatile $ty:t *p, $ty:t val) { + return $id:cuName(($ty:t *)p, val); + }|] + types = [ [C.cty|int|] + , [C.cty|unsigned int|] + , [C.cty|unsigned long long|] + ] + opNames = [ ("atomic_add", "atomicAdd") + , ("atomic_max", "atomicMax") + , ("atomic_min", "atomicMin") + , ("atomic_and", "atomicAnd") + , ("atomic_or", "atomicOr") + , ("atomic_xor", "atomicXor") + , ("atomic_xchg", "atomicExch") + ] + extraOps = + [ [C.cedecl|static inline $ty:t atomic_cmpxchg(volatile $ty:t *p, $ty:t cmp, $ty:t val) { + return atomicCAS(($ty:t *)p, cmp, val); + }|] | t <- types] -calledKernelName :: CallKernel -> String -calledKernelName (Map k) = - mapKernelName k -calledKernelName (AnyKernel k) = - nameToString $ kernelName k +genCUDAPrelude :: OpenClRequirements -> [C.Definition] +genCUDAPrelude (OpenClRequirements _ consts) = + cudafy ++ cudaAtomicOps ++ defs ++ ops + where ops = cIntOps ++ cFloat32Ops ++ cFloat32Funs ++ cFloat64Ops + ++ cFloat64Funs ++ cFloatConvOps + defs = [ [C.cedecl|$esc:def|] | def <- map constToDefine consts ] + cudafy = [CUDAC.cunit| +typedef char int8_t; +typedef short int16_t; +typedef int int32_t; +typedef long int64_t; +typedef unsigned char uint8_t; +typedef unsigned short uint16_t; +typedef unsigned int uint32_t; +typedef unsigned long long uint64_t; +typedef uint8_t uchar; +typedef uint16_t ushort; +typedef uint32_t uint; +typedef uint64_t ulong; +$esc:("#define __kernel extern \"C\" __global__ __launch_bounds__(MAX_THREADS_PER_BLOCK)") +$esc:("#define __global") +$esc:("#define __local") +$esc:("#define __private") +$esc:("#define __constant") +$esc:("#define __write_only") +$esc:("#define __read_only") -kernelArgs :: CallKernel -> [KernelArg] -kernelArgs (Map kernel) = - mapMaybe useToArg $ mapKernelUses kernel -kernelArgs (AnyKernel kernel) = +static inline int get_group_id_fn(int block_dim0, int block_dim1, int block_dim2, int d) +{ + switch (d) { + case 0: d = block_dim0; break; + case 1: d = block_dim1; break; + case 2: d = block_dim2; break; + } + switch (d) { + case 0: return blockIdx.x; + case 1: return blockIdx.y; + case 2: return blockIdx.z; + default: return 0; + } +} +$esc:("#define get_group_id(d) get_group_id_fn(block_dim0, block_dim1, block_dim2, d)") + +static inline int get_num_groups_fn(int block_dim0, int block_dim1, int block_dim2, int d) +{ + switch (d) { + case 0: d = block_dim0; break; + case 1: d = block_dim1; break; + case 2: d = block_dim2; break; + } + switch(d) { + case 0: return gridDim.x; + case 1: return gridDim.y; + case 2: return gridDim.z; + default: return 0; + } +} +$esc:("#define get_num_groups(d) get_num_groups_fn(block_dim0, block_dim1, block_dim2, d)") + +static inline int get_local_id(int d) +{ + switch (d) { + case 0: return threadIdx.x; + case 1: return threadIdx.y; + case 2: return threadIdx.z; + default: return 0; + } +} + +static inline int get_local_size(int d) +{ + switch (d) { + case 0: return blockDim.x; + case 1: return blockDim.y; + case 2: return blockDim.z; + default: return 0; + } +} + +static inline int get_global_id_fn(int block_dim0, int block_dim1, int block_dim2, int d) +{ + return get_group_id(d) * get_local_size(d) + get_local_id(d); +} +$esc:("#define get_global_id(d) get_global_id_fn(block_dim0, block_dim1, block_dim2, d)") + +static inline int get_global_size(int block_dim0, int block_dim1, int block_dim2, int d) +{ + return get_num_groups(d) * get_local_size(d); +} + +$esc:("#define CLK_LOCAL_MEM_FENCE 1") +$esc:("#define CLK_GLOBAL_MEM_FENCE 2") +static inline void barrier(int x) +{ + __syncthreads(); +} +static inline void mem_fence(int x) +{ + if (x == CLK_LOCAL_MEM_FENCE) { + __threadfence_block(); + } else { + __threadfence(); + } +} +$esc:("#define NAN (0.0/0.0)") +$esc:("#define INFINITY (1.0/0.0)") +extern volatile __shared__ char shared_mem[]; +|] + +constToDefine :: (VName, KernelConstExp) -> String +constToDefine (name, e) = + let e' = compilePrimExp e + in unwords ["#define", zEncodeString (pretty name), "("++prettyOneLine e'++")"] + + +compilePrimExp :: PrimExp KernelConst -> C.Exp +compilePrimExp e = runIdentity $ GenericC.compilePrimExp compileKernelConst e + where compileKernelConst (SizeConst key) = + return [C.cexp|$id:(zEncodeString (pretty key))|] + +kernelArgs :: Kernel -> [KernelArg] +kernelArgs kernel = mapMaybe (fmap (SharedMemoryKArg . memSizeToExp) . localMemorySize) (kernelLocalMemory kernel) ++ mapMaybe useToArg (kernelUses kernel) @@ -277,8 +408,10 @@ GenericC.stm [C.cstm|$id:v = get_global_size($int:i);|] kernelOps (GetLockstepWidth v) = GenericC.stm [C.cstm|$id:v = LOCKSTEP_WIDTH;|] - kernelOps Barrier = + kernelOps LocalBarrier = GenericC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|] + kernelOps GlobalBarrier = + GenericC.stm [C.cstm|barrier(CLK_GLOBAL_MEM_FENCE);|] kernelOps MemFence = GenericC.stm [C.cstm|mem_fence(CLK_GLOBAL_MEM_FENCE);|] kernelOps (Atomic aop) = atomicOps aop @@ -361,9 +494,8 @@ useToArg (ScalarUse v bt) = Just $ ValueKArg (LeafExp (ScalarVar v) bt) bt useToArg ConstUse{} = Nothing -typesInKernel :: CallKernel -> S.Set PrimType -typesInKernel (Map kernel) = typesInCode $ mapKernelBody kernel -typesInKernel (AnyKernel kernel) = typesInCode $ kernelBody kernel +typesInKernel :: Kernel -> S.Set PrimType +typesInKernel kernel = typesInCode $ kernelBody kernel typesInCode :: ImpKernels.KernelCode -> S.Set PrimType typesInCode Skip = mempty 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 @@ -7,7 +7,6 @@ where import qualified Data.Set as S -import Data.Semigroup ((<>)) import Prelude hiding (quot, rem) @@ -119,7 +118,7 @@ t (Space "local") Nonvolatile $ index idata (bytes $ (v32 idata_offset + v32 index_in) * tsize) t (Space "global") Nonvolatile] - , Op Barrier + , Op LocalBarrier , SetScalar x_index $ v32 get_group_id_1 * tile_dim + v32 get_local_id_0 , SetScalar y_index $ v32 get_group_id_0 * tile_dim + v32 get_local_id_1 , when (v32 x_index .<. height) $ @@ -203,7 +202,7 @@ t (Space "local") Nonvolatile $ index idata (bytes $ (v32 idata_offset + v32 index_in) * tsize) t (Space "global") Nonvolatile - , Op Barrier + , Op LocalBarrier , SetScalar x_index x_out_index , SetScalar y_index y_out_index , dec index_out $ v32 y_index * height + v32 x_index diff --git a/src/Futhark/CodeGen/ImpGen/Sequential.hs b/src/Futhark/CodeGen/ImpGen/Sequential.hs --- a/src/Futhark/CodeGen/ImpGen/Sequential.hs +++ b/src/Futhark/CodeGen/ImpGen/Sequential.hs @@ -11,7 +11,7 @@ import Futhark.MonadFreshNames compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError Imp.Program) -compileProg = ImpGen.compileProg ops Imp.DefaultSpace +compileProg = ImpGen.compileProg ops Imp.DefaultSpace [] where ops = ImpGen.defaultOperations opCompiler opCompiler :: ImpGen.OpCompiler ExplicitMemory Imp.Sequential opCompiler dest (Alloc e space) = diff --git a/src/Futhark/CodeGen/OpenCL/Kernels.hs b/src/Futhark/CodeGen/OpenCL/Kernels.hs --- a/src/Futhark/CodeGen/OpenCL/Kernels.hs +++ b/src/Futhark/CodeGen/OpenCL/Kernels.hs @@ -44,7 +44,7 @@ [ SizeHeuristic "NVIDIA CUDA" DeviceGPU LockstepWidth $ HeuristicConst 32 , SizeHeuristic "AMD Accelerated Parallel Processing" DeviceGPU LockstepWidth $ HeuristicConst 64 , SizeHeuristic "" DeviceGPU LockstepWidth $ HeuristicConst 1 - , SizeHeuristic "" DeviceGPU NumGroups $ HeuristicConst 128 + , SizeHeuristic "" DeviceGPU NumGroups $ HeuristicConst 256 , SizeHeuristic "" DeviceGPU GroupSize $ HeuristicConst 256 , SizeHeuristic "" DeviceGPU TileSize $ HeuristicConst 32 diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -8,7 +8,6 @@ , FutharkConfig (..) , newFutharkConfig , dumpError - , reportingIOErrors , module Futhark.Compiler.Program , readProgram @@ -16,14 +15,11 @@ ) where -import Data.Semigroup ((<>)) -import Control.Exception import Control.Monad import Control.Monad.Reader import Control.Monad.Except import System.Exit (exitWith, ExitCode(..)) import System.IO -import qualified Data.Text as T import qualified Data.Text.IO as T import Futhark.Internalise @@ -69,23 +65,6 @@ when (fst (futharkVerbose config) > NotVerbose) $ maybe (T.hPutStr stderr) T.writeFile (snd (futharkVerbose config)) $ info <> "\n" - --- | Catch all IO exceptions and print a better error message if they --- happen. Use this at the top-level of all Futhark compiler --- frontends. -reportingIOErrors :: IO () -> IO () -reportingIOErrors = flip catches [Handler onExit, Handler onError] - where onExit :: ExitCode -> IO () - onExit = throwIO - onError :: SomeException -> IO () - onError e - | Just UserInterrupt <- asyncExceptionFromException e = - return () -- This corresponds to CTRL-C, which is not an error. - | otherwise = do - T.hPutStrLn stderr "Internal compiler error (unhandled IO exception)." - T.hPutStrLn stderr "Please report this at https://github.com/diku-dk/futhark/issues" - T.hPutStrLn stderr $ T.pack $ show e - exitWith $ ExitFailure 1 runCompilerOnProgram :: FutharkConfig -> Pipeline I.SOACS lore diff --git a/src/Futhark/Compiler/CLI.hs b/src/Futhark/Compiler/CLI.hs --- a/src/Futhark/Compiler/CLI.hs +++ b/src/Futhark/Compiler/CLI.hs @@ -30,13 +30,14 @@ -> Pipeline SOACS lore -- ^ The pipeline to use. -> (cfg -> CompilerMode -> FilePath -> Prog lore -> FutharkM ()) -- ^ The action to take on the result of the pipeline. + -> String -- ^ Program name + -> [String] -- ^ Command line arguments. -> IO () -compilerMain cfg cfg_opts name desc pipeline doIt = do +compilerMain cfg cfg_opts name desc pipeline doIt prog args = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 - reportingIOErrors $ - mainWithOptions (newCompilerConfig cfg) (commandLineOptions ++ map wrapOption cfg_opts) - "options... program" inspectNonOptions + mainWithOptions (newCompilerConfig cfg) (commandLineOptions ++ map wrapOption cfg_opts) + "options... program" inspectNonOptions prog args where inspectNonOptions [file] config = Just $ compile config file inspectNonOptions _ _ = Nothing diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -15,7 +15,6 @@ ) where -import Data.Semigroup ((<>)) import Data.Loc import Control.Exception import Control.Monad diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs --- a/src/Futhark/Doc/Generator.hs +++ b/src/Futhark/Doc/Generator.hs @@ -376,7 +376,9 @@ synopsisValBindBind (name, BoundV tps t) = do let tps' = map typeParamHtml tps t' <- typeHtml t - return $ keyword "val " <> vnameHtml name <> joinBy " " tps' <> ": " <> t' + return $ + keyword "val " <> vnameHtml name <> + mconcat (map (" "<>) tps') <> ": " <> t' prettyEnum :: [Name] -> Html prettyEnum cs = pipes $ map (("#"<>) . renderName) cs @@ -396,7 +398,7 @@ targs' <- mapM typeArgHtml targs et' <- typeNameHtml et return $ prettyU u <> et' <> joinBy " " targs' - Array et shape u -> do + Array _ u et shape -> do shape' <- prettyShapeDecl shape et' <- prettyElem et return $ prettyU u <> shape' <> et' @@ -410,9 +412,9 @@ t1' <> " -> " <> t2' Enum cs -> return $ prettyEnum cs -prettyElem :: ArrayElemTypeBase (DimDecl VName) () -> DocM Html -prettyElem (ArrayPrimElem et _) = return $ primTypeHtml et -prettyElem (ArrayPolyElem et targs _) = do +prettyElem :: ArrayElemTypeBase (DimDecl VName) -> DocM Html +prettyElem (ArrayPrimElem et) = return $ primTypeHtml et +prettyElem (ArrayPolyElem et targs) = do targs' <- mapM typeArgHtml targs return $ prettyTypeName et <> joinBy " " targs' prettyElem (ArrayRecordElem fs) @@ -423,18 +425,18 @@ where ppField (name, tp) = do tp' <- prettyRecordElem tp return $ toHtml (nameToString name) <> ": " <> tp' -prettyElem (ArrayEnumElem cs _ ) = return $ braces $ prettyEnum cs +prettyElem (ArrayEnumElem cs) = return $ braces $ prettyEnum cs -prettyRecordElem :: RecordArrayElemTypeBase (DimDecl VName) () -> DocM Html +prettyRecordElem :: RecordArrayElemTypeBase (DimDecl VName) -> DocM Html prettyRecordElem (RecordArrayElem et) = prettyElem et -prettyRecordElem (RecordArrayArrayElem et shape u) = - typeHtml $ Array et shape u +prettyRecordElem (RecordArrayArrayElem et shape) = + typeHtml $ Array () Nonunique et shape prettyShapeDecl :: ShapeDecl (DimDecl VName) -> DocM Html prettyShapeDecl (ShapeDecl ds) = mconcat <$> mapM (fmap brackets . dimDeclHtml) ds -typeArgHtml :: TypeArg (DimDecl VName) () -> DocM Html +typeArgHtml :: TypeArg (DimDecl VName) -> DocM Html typeArgHtml (TypeArgDim d _) = brackets <$> dimDeclHtml d typeArgHtml (TypeArgType t _) = typeHtml t diff --git a/src/Futhark/Doc/Html.hs b/src/Futhark/Doc/Html.hs --- a/src/Futhark/Doc/Html.hs +++ b/src/Futhark/Doc/Html.hs @@ -12,8 +12,6 @@ ) where -import Data.Semigroup ((<>)) - import Language.Futhark import Futhark.Util.Pretty (Doc,ppr) diff --git a/src/Futhark/FreshNames.hs b/src/Futhark/FreshNames.hs --- a/src/Futhark/FreshNames.hs +++ b/src/Futhark/FreshNames.hs @@ -9,7 +9,6 @@ , newVNameFromName ) where -import qualified Data.Semigroup as Sem import Language.Haskell.TH.Syntax (Lift) import Language.Futhark.Core @@ -24,12 +23,11 @@ newtype VNameSource = VNameSource Int deriving (Lift, Eq, Ord) -instance Sem.Semigroup VNameSource where +instance Semigroup VNameSource where VNameSource x <> VNameSource y = VNameSource (x `max` y) instance Monoid VNameSource where mempty = blankNameSource - mappend = (Sem.<>) -- | Produce a fresh name, using the given name as a template. newName :: VNameSource -> VName -> (VName, VNameSource) diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -14,7 +14,6 @@ import Control.Monad.Reader import qualified Data.Map.Strict as M import qualified Data.Set as S -import Data.Semigroup ((<>)) import Data.List import Data.Loc import Data.Char (chr) @@ -168,11 +167,11 @@ -> [EntryPointType] entryPointType (_, E.Prim E.Unsigned{}, _) = [I.TypeUnsigned] - entryPointType (_, E.Array (ArrayPrimElem Unsigned{} _) _ _, _) = + entryPointType (_, E.Array _ _ (ArrayPrimElem Unsigned{}) _, _) = [I.TypeUnsigned] entryPointType (_, E.Prim{}, _) = [I.TypeDirect] - entryPointType (_, E.Array ArrayPrimElem{} _ _, _) = + entryPointType (_, E.Array _ _ ArrayPrimElem{} _, _) = [I.TypeDirect] entryPointType (te, t, ts) = [I.TypeOpaque desc $ length ts] @@ -272,7 +271,7 @@ forM flat_arrs $ \flat_arr -> do flat_arr_t <- lookupType flat_arr let new_shape' = reshapeOuter (map (DimNew . constant) new_shape) - (length new_shape) $ arrayShape flat_arr_t + 1 $ arrayShape flat_arr_t letSubExp desc $ I.BasicOp $ I.Reshape new_shape' flat_arr | otherwise = do @@ -1385,8 +1384,7 @@ where isCharLit (Literal (SignedValue iv) _) = Just $ chr $ fromIntegral $ intToInt64 iv isCharLit _ = Nothing - handle [E.TupLit [n, m, arr] _] f - | f `elem` ["unflatten", "cosmin_unflatten"] = Just $ \desc -> do + handle [E.TupLit [n, m, arr] _] "unflatten" = Just $ \desc -> do arrs <- internaliseExpToVars "unflatten_arr" arr n' <- internaliseExp1 "n" n m' <- internaliseExp1 "m" m @@ -1403,8 +1401,7 @@ letSubExp desc $ I.BasicOp $ I.Reshape (reshapeOuter [DimNew n', DimNew m'] 1 $ arrayShape arr_t) arr' - handle [arr] f - | f `elem` ["flatten", "cosmin_flatten"] = Just $ \desc -> do + handle [arr] "flatten" = Just $ \desc -> do arrs <- internaliseExpToVars "flatten_arr" arr forM arrs $ \arr' -> do arr_t <- lookupType arr' @@ -1424,23 +1421,46 @@ mapM (fmap (arraysSize 0) . mapM lookupType) [ys] let conc xarr yarr = do - -- All dimensions except for dimension 'i' must match. + -- All dimensions except the outermost must match. An + -- empty array matches anything. xt <- lookupType xarr yt <- lookupType yarr let matches n m = - letExp "match" =<< - eAssert (pure $ I.BasicOp $ I.CmpOp (I.CmpEq I.int32) n m) - "arguments do not have the same row shape" loc - x_inner_dims = drop 1 $ I.arrayDims xt - y_inner_dims = drop 1 $ I.arrayDims yt - updims = zipWith3 updims' [(0::Int)..] (I.arrayDims xt) - updims' j xd yd | j == 0 = yd - | otherwise = xd - matchcs <- asserting $ Certificates <$> - zipWithM matches x_inner_dims y_inner_dims + letSubExp "match" $ + I.BasicOp $ I.CmpOp (I.CmpEq I.int32) n m + + emptyRow arr_t = + letSubExp "empty_row" =<< + foldBinOp I.LogOr (constant False) =<< + mapM (matches (intConst Int32 0)) (arrayDims $ rowType arr_t) + + all_match <- letSubExp "all_match" =<< + foldBinOp I.LogAnd (constant True) =<< + zipWithM matches + (arrayDims (rowType xt)) (arrayDims (rowType yt)) + xarr_empty <- emptyRow xt + yarr_empty <- emptyRow yt + either_empty <- letSubExp "either_empty" $ + I.BasicOp $ I.BinOp I.LogOr xarr_empty yarr_empty + matchcs <- assertingOne $ letExp "concat_ok" =<< + eAssert (pure $ I.BasicOp $ I.BinOp I.LogOr either_empty all_match) + "row sizes do not match when concatenating" loc + + let updims (j, xd, yd) + | j == 0 = + return (xd, yd) + | otherwise = do + d <- letSubExp "dim" $ I.BasicOp $ I.BinOp (SMax Int32) xd yd + return (d, d) + + (xdims, ydims) <- unzip <$> + mapM updims (zip3 [(0::Int)..] (I.arrayDims xt) (I.arrayDims yt)) + + xarr' <- certifying matchcs $ letExp "concat_x_reshaped" $ + shapeCoerce xdims xarr yarr' <- certifying matchcs $ letExp "concat_y_reshaped" $ - shapeCoerce (updims $ I.arrayDims yt) yarr - return $ I.BasicOp $ I.Concat 0 xarr [yarr'] ressize + shapeCoerce ydims yarr + return $ I.BasicOp $ I.Concat 0 xarr' [yarr'] ressize letSubExps desc =<< zipWithM conc xs ys handle [TupLit [offset, e] _] "rotate" = Just $ \desc -> do 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 @@ -11,7 +11,6 @@ import Data.Loc import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified Data.Semigroup as Sem import qualified Data.Sequence as Seq import Futhark.MonadFreshNames @@ -21,7 +20,7 @@ -- | A static value stores additional information about the result of -- defunctionalization of an expression, aside from the residual expression. data StaticVal = Dynamic CompType - | LambdaSV [VName] Pattern Exp Env + | LambdaSV [VName] Pattern StructType Exp Env -- ^ The 'VName's are shape parameters that are bound -- by the 'Pattern'. | RecordSV [(Name, StaticVal)] @@ -62,8 +61,8 @@ Dynamic $ t `setUniqueness` Nonunique restrict' _ (Dynamic t) = Dynamic t - restrict' u (LambdaSV dims pat e env) = - LambdaSV dims pat e $ M.map (restrict' u) env + restrict' u (LambdaSV dims pat t e env) = + LambdaSV dims pat t e $ M.map (restrict' u) env restrict' u (RecordSV fields) = RecordSV $ map (fmap $ restrict' u) fields restrict' u (DynamicFun (e, sv1) sv2) = @@ -74,9 +73,9 @@ -- the current Env as well as the set of globally defined dynamic -- functions. This is used to avoid unnecessarily large closure -- environments. -newtype DefM a = DefM (RWS (Names, Env) (Seq.Seq ValBind) VNameSource a) +newtype DefM a = DefM (RWS (S.Set VName, Env) (Seq.Seq ValBind) VNameSource a) deriving (Functor, Applicative, Monad, - MonadReader (Names, Env), + MonadReader (S.Set VName, Env), MonadWriter (Seq.Seq ValBind), MonadFreshNames) @@ -211,15 +210,15 @@ (e0', sv) <- defuncExp e0 return (Negate e0' loc, sv) -defuncExp e@(Lambda tparams pats e0 decl tp loc) = do +defuncExp e@(Lambda tparams pats e0 decl (Info (closure, ret)) loc) = do when (any isTypeParam tparams) $ error $ "Received a lambda with type parameters at " ++ locStr loc ++ ", but the defunctionalizer expects a monomorphic input program." -- Extract the first parameter of the lambda and "push" the -- remaining ones (if there are any) into the body of the lambda. - let (dims, pat, e0') = case pats of + let (dims, pat, ret', e0') = case pats of [] -> error "Received a lambda with no parameters." - [pat'] -> (map typeParamName tparams, pat', e0) + [pat'] -> (map typeParamName tparams, pat', ret, e0) (pat' : pats') -> -- Split shape parameters into those that are determined by -- the first pattern, and those that are determined by later @@ -227,14 +226,15 @@ let bound_by_pat = (`S.member` patternDimNames pat') . typeParamName (pat_dims, rest_dims) = partition bound_by_pat tparams in (map typeParamName pat_dims, pat', - Lambda rest_dims pats' e0 decl tp loc) + foldFunType (map (toStruct . patternPatternType) pats') ret, + Lambda rest_dims pats' e0 decl (Info (closure, ret)) loc) -- Construct a record literal that closes over the environment of -- the lambda. Closed-over 'DynamicFun's are converted to their -- closure representation. env <- restrictEnvTo (freeVars e) let (fields, env') = unzip $ map closureFromDynamicFun $ M.toList env - return (RecordLit fields loc, LambdaSV dims pat e0' $ M.fromList env') + return (RecordLit fields loc, LambdaSV dims pat ret' e0' $ M.fromList env') where closureFromDynamicFun (vn, DynamicFun (clsr_env, sv) _) = let name = nameFromString $ pretty vn @@ -489,7 +489,7 @@ (e2', sv2) <- defuncExp e2 let e' = Apply e1' e2' d t loc case sv1 of - LambdaSV dims pat e0 closure_env -> do + LambdaSV dims pat e0_t e0 closure_env -> do let env' = matchPatternSV pat sv2 env_dim = envFromDimNames dims (e0', sv) <- localNewEnv (env' <> closure_env <> env_dim) $ defuncExp e0 @@ -531,7 +531,7 @@ else do -- Lift lambda to top-level function definition. let params = [closure_pat, pat'] - rettype = buildRetType closure_env params $ typeOf e0' + rettype = buildRetType closure_env params e0_t $ typeOf e0' -- Embed some information about the original function -- into the name of the lifted function, to make the @@ -584,9 +584,9 @@ fname <- newName $ qualLeaf qn let (dims, pats, e0, sv') = liftDynFun sv depth (argtypes', rettype) = dynamicFunType sv' argtypes - liftValDec fname rettype dims pats e0 + liftValDec fname (fromStruct rettype) dims pats e0 return (Var (qualName fname) - (Info (foldFunType argtypes' rettype)) loc, sv') + (Info (foldFunType argtypes' $ fromStruct rettype)) loc, sv') IntrinsicSV -> return (e, IntrinsicSV) @@ -608,7 +608,7 @@ -- depth of partial application. liftDynFun :: StaticVal -> Int -> ([VName], [Pattern], Exp, StaticVal) liftDynFun (DynamicFun (e, sv) _) 0 = ([], [], e, sv) -liftDynFun (DynamicFun clsr@(_, LambdaSV dims pat _ _) sv) d +liftDynFun (DynamicFun clsr@(_, LambdaSV dims pat _ _ _) sv) d | d > 0 = let (dims', pats, e', sv') = liftDynFun sv (d-1) in (dims ++ dims', pat : pats, e', DynamicFun clsr sv') liftDynFun sv _ = error $ "Tried to lift a StaticVal " ++ show sv @@ -671,22 +671,27 @@ -- lifted function can create unique arrays as long as they do not -- alias any of its parameters. XXX: it is not clear that this is a -- sufficient property, unfortunately. -buildRetType :: Env -> [Pattern] -> CompType -> PatternType -buildRetType env pats = vacuousShapeAnnotations . descend +buildRetType :: Env -> [Pattern] -> StructType -> CompType -> PatternType +buildRetType env pats = comb where bound = foldMap oneName (M.keys env) <> foldMap patternVars pats boundAsUnique v = maybe False (unique . unInfo . identType) $ find ((==v) . identName) $ S.toList $ foldMap patIdentSet pats problematic v = (v `member` bound) && not (boundAsUnique v) + comb (Record fs_annot) (Record fs_got) = + Record $ M.intersectionWith comb fs_annot fs_got + comb Arrow{} t = vacuousShapeAnnotations $ descend t + comb got _ = fromStruct got + descend t@Array{} - | any problematic (aliases t) = t `setUniqueness` Nonunique + | any (problematic . aliasVar) (aliases t) = t `setUniqueness` Nonunique descend (Record t) = Record $ fmap descend t descend t = t -- | Compute the corresponding type for a given static value. typeFromSV :: StaticVal -> CompType typeFromSV (Dynamic tp) = tp -typeFromSV (LambdaSV _ _ _ env) = typeFromEnv env +typeFromSV (LambdaSV _ _ _ _ env) = typeFromEnv env typeFromSV (RecordSV ls) = Record $ M.fromList $ map (fmap typeFromSV) ls typeFromSV (DynamicFun (_, sv) _) = typeFromSV sv typeFromSV IntrinsicSV = error $ "Tried to get the type from the " @@ -770,12 +775,11 @@ -- A set of names where we also track uniqueness. newtype NameSet = NameSet (M.Map VName Uniqueness) -instance Sem.Semigroup NameSet where +instance Semigroup NameSet where NameSet x <> NameSet y = NameSet $ M.unionWith max x y instance Monoid NameSet where mempty = NameSet mempty - mappend = (Sem.<>) without :: NameSet -> NameSet -> NameSet without (NameSet x) (NameSet y) = NameSet $ x `M.difference` y @@ -789,7 +793,7 @@ oneName :: VName -> NameSet oneName v = NameSet $ M.singleton v Nonunique -names :: Names -> NameSet +names :: S.Set VName -> NameSet names = foldMap oneName -- | Compute the set of free variables of an expression. @@ -883,34 +887,34 @@ -- argument is the orignal type and the second is the type of the transformed -- expression. This is necessary since the original type may contain additional -- information (e.g., shape restrictions) from the user given annotation. -combineTypeShapes :: ArrayDim dim => +combineTypeShapes :: (Monoid as, ArrayDim dim) => TypeBase dim as -> TypeBase dim as -> TypeBase dim as combineTypeShapes (Record ts1) (Record ts2) | M.keys ts1 == M.keys ts2 = - Record $ M.map (uncurry combineTypeShapes) (M.intersectionWith (,) ts1 ts2) -combineTypeShapes (Array et1 shape1 u1) (Array et2 shape2 _u2) + Record $ M.map (uncurry combineTypeShapes) (M.intersectionWith (,) ts1 ts2) +combineTypeShapes (Array als1 u1 et1 shape1) (Array als2 _u2 et2 shape2) | Just new_shape <- unifyShapes shape1 shape2 = - Array (combineElemTypeInfo et1 et2) new_shape u1 + Array (als1<>als2) u1 (combineElemTypeInfo et1 et2) new_shape combineTypeShapes _ new_tp = new_tp combineElemTypeInfo :: ArrayDim dim => - ArrayElemTypeBase dim as - -> ArrayElemTypeBase dim as -> ArrayElemTypeBase dim as + ArrayElemTypeBase dim + -> ArrayElemTypeBase dim -> ArrayElemTypeBase dim combineElemTypeInfo (ArrayRecordElem et1) (ArrayRecordElem et2) = ArrayRecordElem $ M.map (uncurry combineRecordArrayTypeInfo) (M.intersectionWith (,) et1 et2) combineElemTypeInfo _ new_tp = new_tp combineRecordArrayTypeInfo :: ArrayDim dim => - RecordArrayElemTypeBase dim as - -> RecordArrayElemTypeBase dim as - -> RecordArrayElemTypeBase dim as + RecordArrayElemTypeBase dim + -> RecordArrayElemTypeBase dim + -> RecordArrayElemTypeBase dim combineRecordArrayTypeInfo (RecordArrayElem et1) (RecordArrayElem et2) = RecordArrayElem $ combineElemTypeInfo et1 et2 -combineRecordArrayTypeInfo (RecordArrayArrayElem et1 shape1 u1) - (RecordArrayArrayElem et2 shape2 u2) +combineRecordArrayTypeInfo (RecordArrayArrayElem et1 shape1) + (RecordArrayArrayElem et2 shape2) | Just new_shape <- unifyShapes shape1 shape2 = - RecordArrayArrayElem (combineElemTypeInfo et1 et2) new_shape (u1 <> u2) + RecordArrayArrayElem (combineElemTypeInfo et1 et2) new_shape combineRecordArrayTypeInfo _ new_tp = new_tp -- | Defunctionalize a top-level value binding. Returns the @@ -920,12 +924,18 @@ defuncValBind :: ValBind -> DefM (ValBind, Env, Bool) -- Eta-expand entry points with a functional return type. -defuncValBind (ValBind True name retdecl (Info rettype) tparams params body _ loc) +defuncValBind (ValBind True name _ (Info rettype) tparams params body _ loc) | (rettype_ps, rettype') <- unfoldFunType rettype, not $ null rettype_ps = do (body_pats, body', _) <- etaExpand body - defuncValBind $ ValBind True name retdecl (Info rettype') + -- FIXME: we should also handle non-constant size annotations + -- here. + defuncValBind $ ValBind True name Nothing + (Info $ onlyConstantDims rettype') tparams (params <> body_pats) body' Nothing loc + where onlyConstantDims = bimap onDim id + onDim (ConstDim x) = ConstDim x + onDim _ = AnyDim defuncValBind valbind@(ValBind _ name retdecl rettype tparams params body _ _) = do let env = envFromShapeParams tparams 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 @@ -10,7 +10,6 @@ import qualified Data.Set as S import Data.Maybe import Data.Loc -import qualified Data.Semigroup as Sem import Prelude hiding (mod, abs) @@ -53,13 +52,11 @@ Just (ModMod mod_scope) -> lookupSubstInScope (QualName qs name) mod_scope _ -> (qn, scope) -instance Sem.Semigroup Scope where - Scope ss1 mt1 <> Scope ss2 mt2 = - Scope (ss1<>ss2) (mt1<>mt2) +instance Semigroup Scope where + Scope ss1 mt1 <> Scope ss2 mt2 = Scope (ss1<>ss2) (mt1<>mt2) instance Monoid Scope where mempty = Scope mempty mempty - mappend = (Sem.<>) type TySet = S.Set VName diff --git a/src/Futhark/Internalise/Monad.hs b/src/Futhark/Internalise/Monad.hs --- a/src/Futhark/Internalise/Monad.hs +++ b/src/Futhark/Internalise/Monad.hs @@ -40,7 +40,6 @@ import Control.Monad.RWS import qualified Control.Monad.Fail as Fail import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import Futhark.Representation.SOACS import Futhark.MonadFreshNames @@ -75,7 +74,7 @@ } newtype InternaliseResult = InternaliseResult [FunDef] - deriving (Sem.Semigroup, Monoid) + deriving (Semigroup, Monoid) newtype InternaliseM a = InternaliseM (BinderT SOACS (RWST 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 @@ -31,7 +31,6 @@ import Control.Monad.State import Data.Loc import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import qualified Data.Sequence as Seq import Data.Foldable @@ -43,8 +42,13 @@ -- | The monomorphization monad reads 'PolyBinding's and writes 'ValBinding's. -- The 'TypeParam's in a 'ValBinding' can only be shape parameters. -newtype PolyBinding = PolyBinding (VName, [TypeParam], [Pattern], - Maybe (TypeExp VName), StructType, Exp, SrcLoc) +-- +-- Each 'Polybinding' is also connected with the 'RecordReplacements' +-- that were active when the binding was defined. This is used only +-- in local functions. +data PolyBinding = PolyBinding RecordReplacements + (VName, [TypeParam], [Pattern], + Maybe (TypeExp VName), StructType, Exp, SrcLoc) -- | Mapping from record names to the variable names that contain the -- fields. This is used because the monomorphiser also expands all @@ -60,12 +64,11 @@ , envRecordReplacements :: RecordReplacements } -instance Sem.Semigroup Env where +instance Semigroup Env where Env tb1 pb1 rr1 <> Env tb2 pb2 rr2 = Env (tb1 <> tb2) (pb1 <> pb2) (rr1 <> rr2) instance Monoid Env where mempty = Env mempty mempty mempty - mappend = (Sem.<>) localEnv :: Env -> MonoM a -> MonoM a localEnv env = local (env <>) @@ -75,10 +78,10 @@ mempty { envPolyBindings = M.singleton vn binding } withRecordReplacements :: RecordReplacements -> MonoM a -> MonoM a -withRecordReplacements rr = localEnv mempty { envRecordReplacements = rr} +withRecordReplacements rr = localEnv mempty { envRecordReplacements = rr } -noRecordReplacements :: MonoM a -> MonoM a -noRecordReplacements = local $ \env -> env { envRecordReplacements = mempty } +replaceRecordReplacements :: RecordReplacements -> MonoM a -> MonoM a +replaceRecordReplacements rr = local $ \env -> env { envRecordReplacements = rr } -- | The monomorphization monad. newtype MonoM a = MonoM (RWST Env (Seq.Seq (VName, ValBind)) VNameSource @@ -194,7 +197,8 @@ -- Retrieve the lifted monomorphic function bindings that are produced, -- filter those that are monomorphic versions of the current let-bound -- function and insert them at this point, and propagate the rest. - let funbind = PolyBinding (fname, tparams, params, retdecl, ret, body, loc) + rr <- asks envRecordReplacements + let funbind = PolyBinding rr (fname, tparams, params, retdecl, ret, body, loc) pass $ do (e', bs) <- listen $ extendEnv fname funbind $ transformExp e let (bs_local, bs_prop) = Seq.partition ((== fname) . fst) bs @@ -469,8 +473,8 @@ -- list. Monomorphizes the body of the function as well. Returns the fresh name -- of the generated monomorphic function and its 'ValBind' representation. monomorphizeBinding :: PolyBinding -> TypeBase () () -> MonoM (VName, ValBind) -monomorphizeBinding (PolyBinding (name, tparams, params, retdecl, rettype, body, loc)) t = - noRecordReplacements $ do +monomorphizeBinding (PolyBinding rr (name, tparams, params, retdecl, rettype, body, loc)) t = + replaceRecordReplacements rr $ do t' <- removeTypeVariablesInType t let bind_t = foldFunType (map (toStructural . patternType) params) $ toStructural rettype @@ -542,7 +546,7 @@ toPolyBinding :: ValBind -> PolyBinding toPolyBinding (ValBind _ name retdecl (Info rettype) tparams params body _ loc) = - PolyBinding (name, tparams, params, retdecl, rettype, body, loc) + PolyBinding mempty (name, tparams, params, retdecl, rettype, body, loc) -- | Remove all type variables and type abbreviations from a value binding. removeTypeVariables :: ValBind -> MonoM ValBind 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.Set as S import Data.Maybe import Data.Monoid ((<>)) -import Data.Semigroup (Semigroup) import qualified Language.Futhark as E import Futhark.Representation.SOACS as I @@ -114,7 +113,7 @@ fail "internaliseTypeM: cannot handle type variable." E.Record ets -> concat <$> mapM (internaliseTypeM . snd) (E.sortFields ets) - E.Array et shape u -> do + E.Array _ u et shape -> do dims <- internaliseShape shape ets <- internaliseElemType et return [I.arrayOf et' (Shape dims) $ internaliseUniqueness u | et' <- ets ] @@ -123,17 +122,17 @@ where internaliseElemType E.ArrayPolyElem{} = fail "internaliseElemType: cannot handle type variable." - internaliseElemType (E.ArrayPrimElem bt _) = + internaliseElemType (E.ArrayPrimElem bt) = return [I.Prim $ internalisePrimType bt] internaliseElemType (E.ArrayRecordElem elemts) = concat <$> mapM (internaliseRecordElem . snd) (E.sortFields elemts) - internaliseElemType (E.ArrayEnumElem _ _) = + internaliseElemType E.ArrayEnumElem{} = return [I.Prim $ I.IntType I.Int8] internaliseRecordElem (E.RecordArrayElem et) = internaliseElemType et - internaliseRecordElem (E.RecordArrayArrayElem et shape u) = - internaliseTypeM $ E.Array et shape u + internaliseRecordElem (E.RecordArrayArrayElem et shape) = + internaliseTypeM $ E.Array mempty Nonunique et shape internaliseShape = mapM internaliseDim . E.shapeDims diff --git a/src/Futhark/Optimise/CSE.hs b/src/Futhark/Optimise/CSE.hs --- a/src/Futhark/Optimise/CSE.hs +++ b/src/Futhark/Optimise/CSE.hs @@ -35,7 +35,6 @@ import Control.Monad.Reader import qualified Data.Set as S import qualified Data.Map.Strict as M -import Data.Semigroup ((<>)) import Futhark.Analysis.Alias import Futhark.Representation.AST 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 @@ -10,9 +10,7 @@ import Control.Monad.State import Control.Monad.Reader import Control.Monad.Except -import qualified Data.Semigroup as Sem import Data.Maybe -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.List as L @@ -245,7 +243,7 @@ -- ^ The map recording the uses } -instance Sem.Semigroup FusedRes where +instance Semigroup FusedRes where res1 <> res2 = FusedRes (rsucc res1 || rsucc res2) (outArr res1 `M.union` outArr res2) @@ -256,7 +254,6 @@ instance Monoid FusedRes where mempty = FusedRes { rsucc = False, outArr = M.empty, inpArr = M.empty, infusible = S.empty, kernels = M.empty } - mappend = (Sem.<>) isInpArrInResModKers :: FusedRes -> S.Set KernName -> VName -> Bool isInpArrInResModKers ress kers nm = diff --git a/src/Futhark/Optimise/Fusion/Composing.hs b/src/Futhark/Optimise/Fusion/Composing.hs --- a/src/Futhark/Optimise/Fusion/Composing.hs +++ b/src/Futhark/Optimise/Fusion/Composing.hs @@ -18,7 +18,6 @@ where import Data.List -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe 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 @@ -20,7 +20,6 @@ import qualified Data.Set as S import qualified Data.Map.Strict as M import Data.Maybe -import Data.Semigroup ((<>)) import Data.List import Futhark.Representation.SOACS hiding (SOAC(..)) 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 @@ -66,7 +66,6 @@ import Control.Monad.RWS import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified Data.Semigroup as Sem import Futhark.Analysis.Alias import Futhark.Representation.Aliases @@ -196,13 +195,12 @@ , forwardThese :: [DesiredUpdate (LetAttr (Aliases lore))] } -instance Sem.Semigroup (BottomUp lore) where +instance Semigroup (BottomUp lore) where BottomUp seen1 forward1 <> BottomUp seen2 forward2 = BottomUp (seen1 <> seen2) (forward1 <> forward2) instance Monoid (BottomUp lore) where mempty = BottomUp mempty mempty - mappend = (Sem.<>) updateStm :: Constraints lore => DesiredUpdate (LetAttr (Aliases lore)) -> Stm (Aliases lore) updateStm fwd = 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 @@ -11,7 +11,6 @@ , IndexSubstitutions ) where -import Data.Semigroup ((<>)) import Control.Monad import qualified Data.Map.Strict as M import qualified Data.Set as S diff --git a/src/Futhark/Optimise/MemoryBlockMerging/Types.hs b/src/Futhark/Optimise/MemoryBlockMerging/Types.hs --- a/src/Futhark/Optimise/MemoryBlockMerging/Types.hs +++ b/src/Futhark/Optimise/MemoryBlockMerging/Types.hs @@ -18,7 +18,6 @@ where import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import Futhark.Representation.AST import qualified Futhark.Representation.ExplicitMemory as ExpMem @@ -83,9 +82,8 @@ newtype Log = Log (M.Map VName [(String, String)]) deriving (Show, Eq, Ord) -instance Sem.Semigroup Log where +instance Semigroup Log where Log a <> Log b = Log $ M.unionWith (++) a b instance Monoid Log where mempty = Log M.empty - mappend = (Sem.<>) diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs --- a/src/Futhark/Optimise/Simplify.hs +++ b/src/Futhark/Optimise/Simplify.hs @@ -18,8 +18,6 @@ ) where -import Data.Semigroup ((<>)) - import Futhark.Representation.AST import Futhark.MonadFreshNames import qualified Futhark.Optimise.Simplify.Engine as Engine diff --git a/src/Futhark/Optimise/Simplify/ClosedForm.hs b/src/Futhark/Optimise/Simplify/ClosedForm.hs --- a/src/Futhark/Optimise/Simplify/ClosedForm.hs +++ b/src/Futhark/Optimise/Simplify/ClosedForm.hs @@ -16,7 +16,6 @@ import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Set as S -import Data.Semigroup ((<>)) import Futhark.Construct import Futhark.Representation.AST 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,7 +29,6 @@ import Control.Monad.Identity import Control.Monad.Reader -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import Futhark.Representation.AST diff --git a/src/Futhark/Optimise/Simplify/Rule.hs b/src/Futhark/Optimise/Simplify/Rule.hs --- a/src/Futhark/Optimise/Simplify/Rule.hs +++ b/src/Futhark/Optimise/Simplify/Rule.hs @@ -51,9 +51,7 @@ , bottomUpSimplifyStm ) where -import Data.Semigroup ((<>)) import Control.Monad.State -import qualified Data.Semigroup as Sem import qualified Control.Monad.Fail as Fail import Control.Monad.Except @@ -137,13 +135,12 @@ , rulesOp :: [SimplificationRule lore a] } -instance Sem.Semigroup (Rules lore a) where +instance Semigroup (Rules lore a) where Rules as1 bs1 cs1 ds1 es1 <> Rules as2 bs2 cs2 ds2 es2 = Rules (as1<>as2) (bs1<>bs2) (cs1<>cs2) (ds1<>ds2) (es1<>es2) instance Monoid (Rules lore a) where mempty = Rules mempty mempty mempty mempty mempty - mappend = (Sem.<>) -- | Context for a rule applied during top-down traversal of the -- program. Takes a symbol table as argument. @@ -178,12 +175,11 @@ , bookBottomUpRules :: BottomUpRules lore } -instance Sem.Semigroup (RuleBook lore) where +instance Semigroup (RuleBook lore) where RuleBook ts1 bs1 <> RuleBook ts2 bs2 = RuleBook (ts1<>ts2) (bs1<>bs2) instance Monoid (RuleBook lore) where mempty = RuleBook mempty mempty - mappend = (Sem.<>) -- | Construct a rule book from a collection of rules. ruleBook :: [TopDownRule m] 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 @@ -24,7 +24,6 @@ import Data.Foldable (all) import Data.List hiding (all) import Data.Maybe -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S 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 @@ -11,7 +11,6 @@ import Control.Monad.Reader import qualified Data.Set as S import qualified Data.Map.Strict as M -import Data.Semigroup ((<>)) import Data.List import Data.Maybe @@ -25,7 +24,7 @@ tileLoops :: Pass Kernels Kernels tileLoops = Pass "tile loops" "Tile stream loops inside kernels" $ - intraproceduralTransformation optimiseFunDef + fmap Prog . mapM optimiseFunDef . progFunctions optimiseFunDef :: MonadFreshNames m => FunDef Kernels -> m (FunDef Kernels) optimiseFunDef fundec = do @@ -126,7 +125,7 @@ arrs arr_chunk_params = do ((tile_size, tiled_group_size), tile_size_bnds) <- runBinder $ do - tile_size_key <- newVName "tile_size" + tile_size_key <- nameFromString . pretty <$> newVName "tile_size" tile_size <- letSubExp "tile_size" $ Op $ GetSize tile_size_key SizeTile tiled_group_size <- letSubExp "tiled_group_size" $ BasicOp $ BinOp (Mul Int32) tile_size tile_size diff --git a/src/Futhark/Optimise/TileLoops/RegTiling3D.hs b/src/Futhark/Optimise/TileLoops/RegTiling3D.hs --- a/src/Futhark/Optimise/TileLoops/RegTiling3D.hs +++ b/src/Futhark/Optimise/TileLoops/RegTiling3D.hs @@ -22,7 +22,6 @@ import qualified Data.Set as S import qualified Data.Map.Strict as M import Data.List -import Data.Semigroup ((<>)) import Data.Maybe import Futhark.MonadFreshNames @@ -659,7 +658,7 @@ (gidx,sz_x) : (gidy,sz_y) : (gidz,m_M) : untiled_gspace = reverse gspace ((tile_size_x, tile_size_y, tiled_group_size), tile_size_bnds) <- runBinder $ do - tile_size_key <- newVName "tile_size" + tile_size_key <- nameFromString . pretty <$> newVName "tile_size" tile_ct_size <- letSubExp "tile_size" $ Op $ GetSize tile_size_key SizeTile tile_size_x <- letSubExp "tile_size_x" $ BasicOp $ BinOp (SMin Int32) tile_ct_size sz_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 @@ -12,7 +12,6 @@ import qualified Data.Set as S import Data.Maybe import Data.List -import Data.Semigroup ((<>)) import Prelude hiding (quot) @@ -72,6 +71,52 @@ variantAlloc _ = False (variant_allocs, invariant_allocs) = M.partition (variantAlloc . fst) allocs + (alloc_stms, alloc_offsets) <- + memoryRequirements kspace (kernelBodyStms kbody) variant_allocs invariant_allocs + + kbody'' <- either compilerLimitationS pure $ + offsetMemoryInKernelBody alloc_offsets + kbody' + + return (alloc_stms, + Op $ Inner $ Kernel desc kspace ts kbody'') + + where bound_in_kernel = + S.fromList $ M.keys $ scopeOfKernelSpace kspace <> + scopeOf (kernelBodyStms kbody) + +transformExp (Op (Inner (SegRed kspace comm red_op nes ts kbody))) = do + let (kbody', kbody_allocs) = extractBodyAllocations kbody + (red_op', red_op_allocs) = extractLambdaAllocations red_op + variantAlloc (Var v) = v `S.member` bound_in_kernel + variantAlloc _ = False + allocs = kbody_allocs <> red_op_allocs + (variant_allocs, invariant_allocs) = M.partition (variantAlloc . fst) allocs + + (alloc_stms, alloc_offsets) <- + memoryRequirements kspace (bodyStms kbody) variant_allocs invariant_allocs + + either compilerLimitationS pure $ do + kbody'' <- offsetMemoryInBody alloc_offsets kbody' + red_op'' <- offsetMemoryInLambda alloc_offsets red_op' + + return (alloc_stms, + Op $ Inner $ SegRed kspace comm red_op'' nes ts kbody'') + + where bound_in_kernel = + S.fromList $ map fst (spaceDimensions kspace) ++ + M.keys (scopeOfKernelSpace kspace <> + scopeOf (bodyStms kbody)) + +transformExp e = + return (mempty, e) + +memoryRequirements :: KernelSpace + -> Stms InKernel + -> M.Map VName (SubExp, Space) + -> M.Map VName (SubExp, Space) + -> ExpandM (Stms ExplicitMemory, RebaseMap) +memoryRequirements kspace kstms variant_allocs invariant_allocs = do num_threads64 <- newVName "num_threads64" let num_threads64_pat = Pattern [] [PatElem num_threads64 $ MemPrim int64] num_threads64_bnd = Let num_threads64_pat (defAux ()) $ BasicOp $ @@ -83,33 +128,42 @@ (spaceGlobalId kspace, spaceGroupId kspace, spaceLocalId kspace) invariant_allocs (variant_alloc_stms, variant_alloc_offsets) <- - expandedVariantAllocations kspace kbody variant_allocs + expandedVariantAllocations kspace kstms variant_allocs let alloc_offsets = invariant_alloc_offsets <> variant_alloc_offsets alloc_stms = invariant_alloc_stms <> variant_alloc_stms - kbody'' <- either compilerLimitationS pure $ - offsetMemoryInKernelBody alloc_offsets - kbody' { kernelBodyStms = kernelBodyStms kbody' } - - return (oneStm num_threads64_bnd <> alloc_stms, - Op $ Inner $ Kernel desc kspace ts kbody'') - - where bound_in_kernel = - S.fromList $ M.keys $ scopeOfKernelSpace kspace <> - scopeOf (kernelBodyStms kbody) - -transformExp e = - return (mempty, e) + return (oneStm num_threads64_bnd <> alloc_stms, alloc_offsets) -- | Extract allocations from 'Thread' statements with -- 'extractThreadAllocations'. extractKernelBodyAllocations :: KernelBody InKernel -> (KernelBody InKernel, M.Map VName (SubExp, Space)) -extractKernelBodyAllocations kbody = - let (allocs, stms) = mapAccumL extract M.empty $ stmsToList $ kernelBodyStms kbody - in (kbody { kernelBodyStms = mconcat stms }, allocs) +extractKernelBodyAllocations = extractGenericBodyAllocations kernelBodyStms $ + \stms kbody -> kbody { kernelBodyStms = stms } + +extractBodyAllocations :: Body InKernel + -> (Body InKernel, + M.Map VName (SubExp, Space)) +extractBodyAllocations = extractGenericBodyAllocations bodyStms $ + \stms body -> body { bodyStms = stms } + +extractLambdaAllocations :: Lambda InKernel + -> (Lambda InKernel, + M.Map VName (SubExp, Space)) +extractLambdaAllocations lam = (lam { lambdaBody = body' }, allocs) + where (body', allocs) = extractGenericBodyAllocations bodyStms + (\stms body -> body { bodyStms = stms }) $ lambdaBody lam + +extractGenericBodyAllocations :: (body -> Stms InKernel) + -> (Stms InKernel -> body -> body) + -> body + -> (body, + M.Map VName (SubExp, Space)) +extractGenericBodyAllocations get_stms set_stms body = + let (allocs, stms) = mapAccumL extract M.empty $ stmsToList $ get_stms body + in (set_stms (mconcat stms) body, allocs) where extract allocs bnd = let (bnds, body_allocs) = extractThreadAllocations $ oneStm bnd in (allocs <> body_allocs, bnds) @@ -170,17 +224,17 @@ map untouched old_shape in offset_ixfun -expandedVariantAllocations :: KernelSpace -> KernelBody InKernel +expandedVariantAllocations :: KernelSpace -> Stms InKernel -> M.Map VName (SubExp, Space) -> ExpandM (Stms ExplicitMemory, RebaseMap) expandedVariantAllocations _ _ variant_allocs | null variant_allocs = return (mempty, mempty) -expandedVariantAllocations kspace kbody variant_allocs = do +expandedVariantAllocations kspace kstms variant_allocs = do let sizes_to_blocks = removeCommonSizes variant_allocs variant_sizes = map fst sizes_to_blocks (slice_stms, offsets, size_sums) <- - sliceKernelSizes variant_sizes kspace kbody + sliceKernelSizes variant_sizes kspace kstms -- Note the recursive call to expand allocations inside the newly -- produced kernels. slice_stms_tmp <- ExplicitMemory.simplifyStms =<< explicitAllocationsInStms slice_stms @@ -241,6 +295,11 @@ stms' <- stmsFromList . snd <$> mapAccumLM offsetMemoryInStm offsets (stmsToList stms) return $ Body attr stms' res +offsetMemoryInLambda :: RebaseMap -> Lambda InKernel -> Either String (Lambda InKernel) +offsetMemoryInLambda offset lam = do + body <- offsetMemoryInBody offset $ lambdaBody lam + return $ lam { lambdaBody = body } + offsetMemoryInStm :: RebaseMap -> Stm InKernel -> Either String (RebaseMap, Stm InKernel) offsetMemoryInStm offsets (Let pat attr e) = do @@ -319,16 +378,13 @@ ---- Slicing allocation sizes out of a kernel. -unAllocInKernelBody :: KernelBody InKernel - -> Either String (KernelBody Kernels.InKernel) -unAllocInKernelBody = unAllocKernelBody False +unAllocInKernelStms :: Stms InKernel + -> Either String (Stms Kernels.InKernel) +unAllocInKernelStms = unAllocStms False where unAllocBody (Body attr stms res) = Body attr <$> unAllocStms True stms <*> pure res - unAllocKernelBody nested (KernelBody attr stms res) = - KernelBody attr <$> unAllocStms nested stms <*> pure res - unAllocStms nested = fmap (stmsFromList . catMaybes) . mapM (unAllocStm nested) . stmsToList @@ -408,10 +464,10 @@ removeCommonSizes = M.toList . foldl' comb mempty . M.toList where comb m (mem, (size, space)) = M.insertWith (++) size [(mem, space)] m -sliceKernelSizes :: [SubExp] -> KernelSpace -> KernelBody InKernel +sliceKernelSizes :: [SubExp] -> KernelSpace -> Stms InKernel -> ExpandM (Stms Kernels.Kernels, [VName], [VName]) -sliceKernelSizes sizes kspace kbody = do - kbody' <- either compilerLimitationS return $ unAllocInKernelBody kbody +sliceKernelSizes sizes kspace kstms = do + kstms' <- either compilerLimitationS return $ unAllocInKernelStms kstms let num_sizes = length sizes i64s = replicate num_sizes $ Prim int64 inkernels_scope <- asks unAllocScope @@ -430,7 +486,7 @@ params <- replicateM num_sizes $ newParam "x" (Prim int64) (zs, stms) <- localScope (scopeOfLParams params <> scopeOfKernelSpace kspace) $ collectStms $ do - mapM_ addStm $ kernelBodyStms kbody' + mapM_ addStm kstms' return sizes localScope (scopeOfKernelSpace kspace) $ Kernels.simplifyLambda kspace -- XXX, is this the right KernelSpace? 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 @@ -529,16 +529,25 @@ return $ FunDef entry fname (memoryInRetType rettype) params' fbody' handleKernel :: Kernel InInKernel - -> AllocM fromlore2 ExplicitMemory (MemOp (Kernel OutInKernel)) + -> AllocM Kernels ExplicitMemory (MemOp (Kernel OutInKernel)) handleKernel (GetSize key size_class) = return $ Inner $ GetSize key size_class handleKernel (GetSizeMax size_class) = return $ Inner $ GetSizeMax size_class handleKernel (CmpSizeLe key size_class x) = return $ Inner $ CmpSizeLe key size_class x -handleKernel (Kernel desc space kernel_ts kbody) = subAllocM handleKernelExp True $ +handleKernel (Kernel desc space kernel_ts kbody) = subInKernel $ Inner . Kernel desc space kernel_ts <$> localScope (scopeOfKernelSpace space) (allocInKernelBody kbody) + +handleKernel (SegRed space comm red_op nes ts body) = do + body' <- subInKernel $ localScope (scopeOfKernelSpace space) $ allocInBodyNoDirect body + red_op' <- allocInSegRedLambda (spaceGlobalId space) (spaceNumThreads space) red_op + return $ Inner $ SegRed space comm red_op' nes ts body' + +subInKernel :: AllocM InInKernel OutInKernel a + -> AllocM fromlore2 ExplicitMemory a +subInKernel = subAllocM handleKernelExp True where handleKernelExp (Barrier se) = return $ Inner $ Barrier se @@ -756,7 +765,7 @@ (acc_params, arr_params) = splitAt (length input_summaries) actual_params this_index = LeafExp i int32 - other_index = LeafExp (paramName j_param) int32 + other_index = this_index + LeafExp (paramName j_param) int32 acc_params' <- allocInReduceParameters this_index $ zip acc_params input_summaries @@ -784,6 +793,48 @@ Mem size space -> return p { paramAttr = MemMem size space } +allocInSegRedLambda :: VName -> SubExp -> Lambda InInKernel + -> AllocM Kernels ExplicitMemory (Lambda OutInKernel) +allocInSegRedLambda gtid num_threads lam = do + let (acc_params, arr_params) = + splitAt (length (lambdaParams lam) `div` 2) $ lambdaParams lam + this_index = LeafExp gtid int32 + other_index = this_index + primExpFromSubExp int32 num_threads + (acc_params', arr_params') <- + allocInSegRedParameters num_threads this_index other_index acc_params arr_params + + subInKernel $ allocInLambda (acc_params' ++ arr_params') + (lambdaBody lam) (lambdaReturnType lam) + +allocInSegRedParameters :: SubExp + -> PrimExp VName -> PrimExp VName + -> [LParam InInKernel] + -> [LParam InInKernel] + -> AllocM Kernels ExplicitMemory ([LParam ExplicitMemory], [LParam ExplicitMemory]) +allocInSegRedParameters num_threads my_id other_id xs ys = unzip <$> zipWithM alloc xs ys + where alloc x y = + case paramType x of + Array bt shape u -> do + twice_num_threads <- letSubExp "twice_num_threads" $ + BasicOp $ BinOp (Mul Int32) num_threads $ intConst Int32 2 + let t = paramType x `arrayOfRow` twice_num_threads + (_, mem) <- allocForArray t DefaultSpace + -- XXX: this iota ixfun is a bit inefficient; leading to uncoalesced access. + let ixfun_base = IxFun.iota $ + map (primExpFromSubExp int32) (arrayDims t) + ixfun_x = IxFun.slice ixfun_base $ + fullSliceNum (IxFun.shape ixfun_base) [DimFix my_id] + ixfun_y = IxFun.slice ixfun_base $ + fullSliceNum (IxFun.shape ixfun_base) [DimFix other_id] + return (x { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun_x }, + y { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun_y }) + Prim bt -> + return (x { paramAttr = MemPrim bt }, + y { paramAttr = MemPrim bt }) + Mem size space -> + return (x { paramAttr = MemMem size space }, + y { paramAttr = MemMem size space }) + allocInChunkedParameters :: PrimExp VName -> [(LParam InInKernel, (VName, IxFun))] -> AllocM InInKernel OutInKernel [LParam OutInKernel] @@ -961,6 +1012,7 @@ ixfun = IxFun.permute (IxFun.iota $ map (primExpFromSubExp int32) dims') perm_inv return [Hint ixfun DefaultSpace] + kernelExpHints (Op (Inner (Kernel _ space rets kbody))) = zipWithM hint rets $ kernelBodyResult kbody where num_threads = spaceNumThreads space @@ -975,17 +1027,6 @@ coalesceReturnOfShape bs [Constant (IntValue (Int32Value d))] = bs * d > 4 coalesceReturnOfShape _ _ = True - innermost space_dims t_dims = - let r = length t_dims - dims = space_dims ++ t_dims - perm = [length space_dims..length space_dims+r-1] ++ - [0..length space_dims-1] - perm_inv = rearrangeInverse perm - dims_perm = rearrangeShape perm dims - ixfun_base = IxFun.iota $ map (primExpFromSubExp int32) dims_perm - ixfun_rearranged = IxFun.permute ixfun_base perm_inv - in ixfun_rearranged - hint t (ThreadsReturn threads _) | coalesceReturnOfShape (primByteSize (elemType t)) $ arrayDims t, Just space_dims <- spacy threads = do @@ -1004,8 +1045,29 @@ return $ Hint ixfun DefaultSpace hint _ _ = return NoHint + +kernelExpHints (Op (Inner (SegRed space _ _ nes ts body))) = + (map (const NoHint) red_res <>) <$> zipWithM mapHint (drop (length nes) ts) map_res + where (red_res, map_res) = splitAt (length nes) $ bodyResult body + + mapHint t _ = do + t_dims <- mapM dimAllocationSize $ arrayDims t + return $ Hint (innermost (map snd $ spaceDimensions space) t_dims) DefaultSpace + kernelExpHints e = return $ replicate (expExtTypeSize e) NoHint + +innermost :: [SubExp] -> [SubExp] -> IxFun +innermost space_dims t_dims = + let r = length t_dims + dims = space_dims ++ t_dims + perm = [length space_dims..length space_dims+r-1] ++ + [0..length space_dims-1] + perm_inv = rearrangeInverse perm + dims_perm = rearrangeShape perm dims + ixfun_base = IxFun.iota $ map (primExpFromSubExp int32) dims_perm + ixfun_rearranged = IxFun.permute ixfun_base perm_inv + in ixfun_rearranged inKernelExpHints :: (Allocator lore m, Op lore ~ MemOp (KernelExp somelore)) => Exp lore -> m [ExpHint] 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 @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} -- | Kernel extraction. -- -- In the following, I will use the term "width" to denote the amount @@ -163,12 +164,11 @@ import Control.Monad.RWS.Strict import Control.Monad.Reader +import Control.Monad.Writer.Strict import Control.Monad.Trans.Maybe -import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe import Data.List -import qualified Data.Semigroup as Sem import Futhark.Representation.SOACS import Futhark.Representation.SOACS.Simplify (simplifyStms, simpleSOACS) @@ -200,31 +200,38 @@ extractKernels = Pass { passName = "extract kernels" , passDescription = "Perform kernel extraction" - , passFunction = runDistribM . fmap Prog . mapM transformFunDef . progFunctions + , passFunction = fmap Prog . mapM transformFunDef . progFunctions } -newtype DistribM a = DistribM (RWS (Scope Out.Kernels) Log VNameSource a) +-- In order to generate more stable threshold names, we keep track of +-- the numbers used for thresholds separately from the ordinary name +-- source, +data State = State { stateNameSource :: VNameSource + , stateThresholdCounter :: Int + } + +newtype DistribM a = DistribM (RWS (Scope Out.Kernels) Log State a) deriving (Functor, Applicative, Monad, - HasScope Out.Kernels, - LocalScope Out.Kernels, - MonadFreshNames, + HasScope Out.Kernels, LocalScope Out.Kernels, + MonadState State, MonadLogger) +instance MonadFreshNames DistribM where + getNameSource = gets stateNameSource + putNameSource src = modify $ \s -> s { stateNameSource = src } + runDistribM :: (MonadLogger m, MonadFreshNames m) => DistribM a -> m a runDistribM (DistribM m) = do - (x, msgs) <- modifyNameSource $ positionNameSource . runRWS m M.empty + (x, msgs) <- modifyNameSource $ \src -> + let (x, s, msgs) = runRWS m mempty (State src 0) + in ((x, msgs), stateNameSource s) addLog msgs return x - where positionNameSource (x, src, msgs) = ((x, msgs), src) -runDistribM' :: MonadFreshNames m => DistribM a -> m a -runDistribM' (DistribM m) = - fmap fst $ modifyNameSource $ positionNameSource . runRWS m M.empty - where positionNameSource (x, src, msgs) = ((x, msgs), src) - -transformFunDef :: FunDef -> DistribM (Out.FunDef Out.Kernels) -transformFunDef (FunDef entry name rettype params body) = do +transformFunDef :: (MonadFreshNames m, MonadLogger m) => + FunDef -> m (Out.FunDef Out.Kernels) +transformFunDef (FunDef entry name rettype params body) = runDistribM $ do body' <- localScope (scopeOfFParams params) $ transformBody mempty body return $ FunDef entry name rettype params body' @@ -262,9 +269,10 @@ transformStm :: KernelPath -> Stm -> DistribM KernelsStms -transformStm path (Let pat aux (Op (CmpThreshold what s))) = +transformStm path (Let pat aux (Op (CmpThreshold what s))) = do + ((r, _), stms) <- cmpSizeLe s (Out.SizeThreshold path) what runBinder_ $ do - (r, _) <- cmpSizeLe s (Out.SizeThreshold path) what + addStms stms addStm $ Let pat aux $ BasicOp $ SubExp r transformStm path (Let pat aux (If c tb fb rt)) = do @@ -324,11 +332,12 @@ transformStm path (Let pat (StmAux cs _) (Op (Screma w form arrs))) | Just (comm, red_lam, nes, map_lam) <- isRedomapSOAC form = do - let paralleliseOuter = do + let paralleliseOuter = runBinder_ $ do red_lam_sequential <- Kernelise.transformLambda red_lam map_lam_sequential <- Kernelise.transformLambda map_lam - fmap (certify cs) <$> - blockedReduction pat w comm' red_lam_sequential map_lam_sequential [] nes arrs + addStms =<< + (fmap (certify cs) <$> + nonSegRed pat w comm' red_lam_sequential map_lam_sequential nes arrs) outerParallelBody = renameBody =<< @@ -342,7 +351,6 @@ renameBody =<< (mkBody <$> paralleliseInner path' <*> pure (map Var (patternNames pat))) - comm' | commutativeLambda red_lam = Commutative | otherwise = comm @@ -350,7 +358,7 @@ then paralleliseOuter else if incrementalFlattening then do ((outer_suff, outer_suff_key), suff_stms) <- - runBinder $ sufficientParallelism "suff_outer_redomap" w path + sufficientParallelism "suff_outer_redomap" w path outer_stms <- outerParallelBody inner_stms <- innerParallelBody ((outer_suff_key, False):path) @@ -370,7 +378,7 @@ transformStm path (Let pat aux@(StmAux cs _) (Op (Stream w (Parallel o comm red_fun nes) fold_fun arrs))) | incrementalFlattening = do ((outer_suff, outer_suff_key), suff_stms) <- - runBinder $ sufficientParallelism "suff_outer_stream" w path + sufficientParallelism "suff_outer_stream" w path outer_stms <- outerParallelBody ((outer_suff_key, True) : path) inner_stms <- innerParallelBody ((outer_suff_key, False) : path) @@ -466,13 +474,11 @@ mapLoopStm :: MapLoop -> Stm mapLoopStm (MapLoop pat cs w lam arrs) = Let pat (StmAux cs ()) $ Op $ Screma w (mapSOAC lam) arrs -sufficientParallelism :: (Op (Lore m) ~ Kernel innerlore, MonadBinder m) => - String -> SubExp -> KernelPath -> m (SubExp, VName) +sufficientParallelism :: String -> SubExp -> KernelPath + -> DistribM ((SubExp, Name), Out.Stms Out.Kernels) sufficientParallelism desc what path = cmpSizeLe desc (Out.SizeThreshold path) what -distributeMap :: (HasScope Out.Kernels m, - MonadFreshNames m, MonadLogger m) => - KernelPath -> MapLoop -> m KernelsStms +distributeMap :: KernelPath -> MapLoop -> DistribM KernelsStms distributeMap path (MapLoop pat cs w lam arrs) = do types <- askScope let loopnest = MapNesting pat cs w $ zip (lambdaParams lam) arrs @@ -505,7 +511,7 @@ return $ postKernelsStms postkernels <> identityStms (outerTarget $ kernelTargets acc') - distributeMap' (newKernel loopnest) path exploitOuterParallelism exploitInnerParallelism pat w lam + distributeMap' id (newKernel loopnest) path exploitOuterParallelism exploitInnerParallelism pat w lam where acc = KernelAcc { kernelTargets = singleTarget (pat, bodyResult $ lambdaBody lam) , kernelStms = mempty } @@ -520,19 +526,20 @@ Let (Pattern [] [pe]) (defAux ()) $ BasicOp $ Replicate (Shape [w]) se distributeMap' :: (HasScope Out.Kernels m, MonadFreshNames m) => - KernelNest -> KernelPath + (forall a. DistribM a -> m a) + -> KernelNest -> KernelPath -> (KernelPath -> m (Out.Stms Out.Kernels)) -> (KernelPath -> m (Out.Stms Out.Kernels)) -> PatternT Type -> SubExp -> LambdaT SOACS -> m (Out.Stms Out.Kernels) -distributeMap' loopnest path mk_seq_stms mk_par_stms pat nest_w lam = do +distributeMap' distribM loopnest path mk_seq_stms mk_par_stms pat nest_w lam = do let res = map Var $ patternNames pat types <- askScope - ((outer_suff, outer_suff_key), outer_suff_stms) <- runBinder $ - sufficientParallelism "suff_outer_par" nest_w path + ((outer_suff, outer_suff_key), outer_suff_stms) <- + distribM $ sufficientParallelism "suff_outer_par" nest_w path intra <- if worthIntraGroup lam then flip runReaderT types $ intraGroupParallelise loopnest lam @@ -550,20 +557,26 @@ Just ((_intra_min_par, intra_avail_par), group_size, intra_prelude, intra_stms) -> do -- We must check that all intra-group parallelism fits in a group. - ((intra_ok, intra_suff_key), intra_suff_stms) <- runBinder $ do - addStms intra_prelude + ((intra_ok, intra_suff_key), intra_suff_stms) <- do - max_group_size <- - letSubExp "max_group_size" $ Op $ Out.GetSizeMax Out.SizeGroup - fits <- letSubExp "fits" $ BasicOp $ - CmpOp (CmpSle Int32) group_size max_group_size + ((intra_suff, suff_key), check_suff_stms) <- + distribM $ sufficientParallelism "suff_intra_par" intra_avail_par $ + (outer_suff_key, False) : path - (intra_suff, suff_key) <- sufficientParallelism "suff_intra_par" intra_avail_par $ - (outer_suff_key, False) : path + runBinder $ do - intra_ok <- letSubExp "intra_suff_and_fits" $ BasicOp $ BinOp LogAnd fits intra_suff - return (intra_ok, suff_key) + addStms intra_prelude + max_group_size <- + letSubExp "max_group_size" $ Op $ Out.GetSizeMax Out.SizeGroup + fits <- letSubExp "fits" $ BasicOp $ + CmpOp (CmpSle Int32) group_size max_group_size + + addStms check_suff_stms + + intra_ok <- letSubExp "intra_suff_and_fits" $ BasicOp $ BinOp LogAnd fits intra_suff + return (intra_ok, suff_key) + group_par_body <- renameBody $ mkBody intra_stms res par_body <- renameBody =<< mkBody <$> @@ -587,24 +600,22 @@ , accLog :: Log } -instance Sem.Semigroup KernelRes where +instance Semigroup KernelRes where KernelRes ks1 log1 <> KernelRes ks2 log2 = KernelRes (ks1 <> ks2) (log1 <> log2) instance Monoid KernelRes where mempty = KernelRes mempty mempty - mappend = (Sem.<>) newtype PostKernel = PostKernel { unPostKernel :: KernelsStms } newtype PostKernels = PostKernels [PostKernel] -instance Sem.Semigroup PostKernels where +instance Semigroup PostKernels where PostKernels xs <> PostKernels ys = PostKernels $ ys ++ xs instance Monoid PostKernels where mempty = PostKernels mempty - mappend = (Sem.<>) postKernelsStms :: PostKernels -> KernelsStms postKernelsStms (PostKernels kernels) = mconcat $ map unPostKernel kernels @@ -622,12 +633,20 @@ stms <- runBinder_ $ Kernelise.transformStm bnd return acc { kernelStms = stms <> kernelStms acc } -newtype KernelM a = KernelM (RWS KernelEnv KernelRes VNameSource a) +newtype KernelM a = KernelM (ReaderT KernelEnv (WriterT KernelRes DistribM) a) deriving (Functor, Applicative, Monad, MonadReader KernelEnv, - MonadWriter KernelRes, - MonadFreshNames) + MonadWriter KernelRes) +liftDistribM :: DistribM a -> KernelM a +liftDistribM m = do + scope <- askScope + KernelM $ lift $ lift $ localScope scope m + +instance MonadFreshNames KernelM where + getNameSource = KernelM $ lift getNameSource + putNameSource = KernelM . lift . putNameSource + instance HasScope Out.Kernels KernelM where askScope = asks kernelScope @@ -638,13 +657,11 @@ instance MonadLogger KernelM where addLog msgs = tell mempty { accLog = msgs } -runKernelM :: (MonadFreshNames m, MonadLogger m) => - KernelEnv -> KernelM a -> m (a, PostKernels) +runKernelM :: KernelEnv -> KernelM a -> DistribM (a, PostKernels) runKernelM env (KernelM m) = do - (x, res) <- modifyNameSource $ getKernels . runRWS m env + (x, res) <- runWriterT $ runReaderT m env addLog $ accLog res return (x, accPostKernels res) - where getKernels (x,s,a) = ((x, a), s) collectKernels :: KernelM a -> KernelM (a, PostKernels) collectKernels m = pass $ do @@ -841,7 +858,7 @@ let outer_pat = loopNestingPattern $ fst nest path <- asks kernelPath addKernel =<< (nestw_bnds<>) <$> - localScope extra_scope (distributeMap' nest' path + localScope extra_scope (distributeMap' liftDistribM nest' path (const $ return $ oneStm sequentialised_kernel) exploitInnerParallelism outer_pat nestw @@ -908,13 +925,11 @@ addKernels kernels nest' <- expandKernelNest pat_unused nest types <- asksScope scopeForSOACs - scope <- askScope + bnds <- runReaderT (interchangeLoops nest' (SeqLoop perm pat val form body)) types - -- runDistribM starts out with an empty scope, so we have to - -- immmediately insert the real one. path <- asks kernelPath - bnds' <- runDistribM $ localScope scope $ transformStms path $ stmsToList bnds + bnds' <- liftDistribM $ transformStms path $ stmsToList bnds addKernel bnds' return acc' _ -> @@ -937,11 +952,9 @@ types <- asksScope scopeForSOACs let branch = Branch perm pat cond tbranch fbranch ret stms <- runReaderT (interchangeBranch nest' branch) types - -- runDistribM starts out with an empty scope, so we have to - -- immmediately insert the real one. - scope <- askScope + path <- asks kernelPath - stms' <- runDistribM $ localScope scope $ transformStms path $ stmsToList stms + stms' <- liftDistribM $ transformStms path $ stmsToList stms addKernel stms' return acc' _ -> @@ -1293,7 +1306,7 @@ -- array). They will not be used anywhere else (due to uniqueness -- constraints), so this is safe. let all_dests = concatMap genReduceDest ops' - (nest_stms<>) <$> + liftDistribM $ (nest_stms<>) <$> inScopeOf nest_stms (genReduceKernel path (kernelNestLoops $ removeArraysFromNest all_dests nest) orig_pat ispace inputs cs genred_w ops' lam arrs) @@ -1301,12 +1314,11 @@ maybe bad return $ find ((==a) . kernelInputName) kernel_inps bad = fail "Ill-typed nested GenReduce encountered." -genReduceKernel :: (HasScope Out.Kernels m, MonadFreshNames m) => - KernelPath -> [LoopNesting] +genReduceKernel :: KernelPath -> [LoopNesting] -> Pattern -> [(VName, SubExp)] -> [KernelInput] -> Certificates -> SubExp -> [GenReduceOp SOACS] -> InKernelLambda -> [VName] - -> m KernelsStms + -> DistribM KernelsStms genReduceKernel path nests orig_pat ispace inputs cs genred_w ops lam arrs = do ops' <- forM ops $ \(GenReduceOp num_bins dests nes op) -> GenReduceOp num_bins dests nes <$> Kernelise.transformLambda op @@ -1314,26 +1326,17 @@ let isDest = flip elem $ concatMap genReduceDest ops' inputs' = filter (not . isDest . kernelInputArray) inputs - runBinder_ $ do - (histos, k_stms) <- blockedGenReduce genred_w ispace inputs' ops' lam arrs - - addStms $ fmap (certify cs) k_stms + (histos, k_stms) <- blockedGenReduce genred_w ispace inputs' ops' lam arrs - let histos' = chunks (map (length . genReduceDest) ops') histos - pes = chunks (map (length . genReduceDest) ops') $ patternElements orig_pat + let histos' = chunks (map (length . genReduceDest) ops') histos + pes = chunks (map (length . genReduceDest) ops') $ patternElements orig_pat - mapM_ combineIntermediateResults (zip3 pes ops histos') + (fmap (certify cs) k_stms<>) . mconcat <$> + inScopeOf k_stms (mapM combineIntermediateResults (zip3 pes ops histos')) where depth = length nests - combineIntermediateResults (pes, GenReduceOp num_bins _ nes op, histos) = do - num_histos <- arraysSize depth <$> mapM lookupType histos - - -- Avoid the segmented reduction if num_histos is 1. - num_histos_is_one <- - letSubExp "num_histos_is_one" $ - BasicOp $ CmpOp (CmpEq int32) num_histos $ intConst Int32 1 - + mkBodies num_histos pes num_bins nes op histos = runBinder $ do body_with_reshape <- runBodyBinder $ fmap resultBody $ forM histos $ \histo -> do histo_dims <- arrayDims <$> lookupType histo @@ -1361,20 +1364,35 @@ nests' <- moreArrays (map paramName map_params) histos_tr_t histos_tr $ nests ++ [MapNesting inner_segred_pat cs num_bins $ zip (lambdaParams lam) arrs] + let collapse_body = reconstructMapNest nests' (map (rowType . patElemType) pes) $ mkBody map_stms $ map Var map_res - scope <- askScope + return (body_with_reshape, collapse_body) + + combineIntermediateResults (pes, GenReduceOp num_bins _ nes op, histos) = do + num_histos <- arraysSize depth <$> mapM lookupType histos + + ((body_with_reshape, collapse_body), aux_stms) <- mkBodies num_histos pes num_bins nes op histos + segmented_reduce_stms <- - runDistribM' $ localScope scope $ transformStms path $ - stmsToList $ bodyStms collapse_body + inScopeOf aux_stms $ transformStms path $ stmsToList $ bodyStms collapse_body let body_with_segred = mkBody segmented_reduce_stms $ bodyResult collapse_body - letBindNames (map patElemName pes) $ - If num_histos_is_one body_with_reshape body_with_segred $ - IfAttr (staticShapes $ map patElemType pes) IfNormal + runBinder_ $ do + addStms aux_stms + + -- Avoid the segmented reduction if num_histos is 1. + num_histos_is_one <- + letSubExp "num_histos_is_one" $ + BasicOp $ CmpOp (CmpEq int32) num_histos $ intConst Int32 1 + + letBindNames (map patElemName pes) $ + If num_histos_is_one body_with_reshape body_with_segred $ + IfAttr (staticShapes $ map patElemType pes) IfNormal + reconstructMapNest :: [LoopNesting] -> [Type] -> BodyT SOACS -> BodyT SOACS reconstructMapNest [] _ body = body reconstructMapNest (MapNesting pat cs w ps_and_arrs : nests) ts body = @@ -1425,11 +1443,8 @@ regularSegmentedRedomapKernel nest perm segment_size comm lam map_lam nes arrs = isSegmentedOp nest perm segment_size (lambdaReturnType map_lam) (freeInLambda lam) (freeInLambda map_lam) nes arrs $ - \pat flat_pat num_segments total_num_elements ispace inps nes' _ arrs' -> do - fold_lam <- composeLambda nilFn lam map_lam - regularSegmentedRedomap - segment_size num_segments (kernelNestWidths nest) - flat_pat pat total_num_elements comm lam fold_lam ispace inps nes' arrs' + \pat _flat_pat _num_segments total_num_elements ispace inps nes' _ _ -> + addStms =<< segRed pat total_num_elements segment_size comm lam map_lam nes' arrs ispace inps isSegmentedOp :: KernelNest -> [Int] @@ -1564,6 +1579,16 @@ return pe { patElemName = name , patElemAttr = patElemType pe `arrayOfShape` Shape dims } + +cmpSizeLe :: String -> Out.SizeClass -> SubExp + -> DistribM ((SubExp, Name), Out.Stms Out.Kernels) +cmpSizeLe desc size_class to_what = do + x <- gets stateThresholdCounter + modify $ \s -> s { stateThresholdCounter = x + 1} + let size_key = nameFromString $ desc ++ "_" ++ show x + runBinder $ do + cmp_res <- letSubExp desc $ Op $ CmpSizeLe size_key size_class to_what + return (cmp_res, size_key) kernelAlternatives :: (MonadFreshNames m, HasScope Out.Kernels m) => Out.Pattern Out.Kernels 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 @@ -7,6 +7,9 @@ , blockedMap , blockedScan + , segRed + , nonSegRed + , mapKernel , mapKernelFromBody , KernelInput(..) @@ -18,14 +21,12 @@ , chunkLambda , splitArrays , getSize - , cmpSizeLe ) where import Control.Monad import Data.Maybe import Data.List -import Data.Semigroup ((<>)) import qualified Data.Set as S import Prelude hiding (quot) @@ -48,16 +49,9 @@ getSize :: (MonadBinder m, Op (Lore m) ~ Kernel innerlore) => String -> SizeClass -> m SubExp getSize desc size_class = do - size_key <- newVName desc + size_key <- nameFromString . pretty <$> newVName desc letSubExp desc $ Op $ GetSize size_key size_class -cmpSizeLe :: (MonadBinder m, Op (Lore m) ~ Kernel innerlore) => - String -> SizeClass -> SubExp -> m (SubExp, VName) -cmpSizeLe desc size_class to_what = do - size_key <- newVName desc - cmp_res <- letSubExp desc $ Op $ CmpSizeLe size_key size_class to_what - return (cmp_res, size_key) - blockedReductionStream :: (MonadFreshNames m, HasScope Kernels m) => Pattern Kernels -> SubExp @@ -290,6 +284,58 @@ fold_chunk_param : fold_inp_params } + +segRed :: (MonadFreshNames m, HasScope Kernels m) => + Pattern Kernels + -> SubExp + -> SubExp -- segment size + -> Commutativity + -> Lambda InKernel -> Lambda InKernel + -> [SubExp] -> [VName] + -> [(VName, SubExp)] -- ispace = pair of (gtid, size) for the maps on "top" of this reduction + -> [KernelInput] -- inps = inputs that can be looked up by using the gtids from ispace + -> m (Stms Kernels) +segRed pat total_num_elements w comm reduce_lam map_lam nes arrs ispace inps = runBinder_ $ do + (_, KernelSize num_groups group_size _ _ num_threads) <- blockedKernelSize =<< asIntS Int64 total_num_elements + gtid <- newVName "gtid" + kspace <- newKernelSpace (num_groups, group_size, num_threads) $ FlatThreadSpace $ + ispace ++ [(gtid, w)] + body <- runBodyBinder $ localScope (scopeOfKernelSpace kspace) $ do + mapM_ (addStm <=< readKernelInput) inps + forM_ (zip (lambdaParams map_lam) arrs) $ \(p, arr) -> do + arr_t <- lookupType arr + letBindNames_ [paramName p] $ + BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var gtid] + return $ lambdaBody map_lam + + letBind_ pat $ Op $ + SegRed kspace comm reduce_lam nes (lambdaReturnType map_lam) body + +nonSegRed :: (MonadFreshNames m, HasScope Kernels m) => + Pattern Kernels + -> SubExp + -> Commutativity + -> Lambda InKernel + -> Lambda InKernel + -> [SubExp] + -> [VName] + -> m (Stms Kernels) +nonSegRed pat w comm red_lam map_lam nes arrs = runBinder_ $ do + -- We add a unit-size segment on top to ensure that the result + -- of the SegRed is an array, which we then immediately index. + -- This is useful in the case that the value is used on the + -- device afterwards, as this may save an expensive + -- host-device copy (scalars are kept on the host, but arrays + -- may be on the device). + let addDummyDim t = t `arrayOfRow` intConst Int32 1 + pat' <- fmap addDummyDim <$> renamePattern pat + dummy <- newVName "dummy" + addStms =<< + segRed pat' w w comm red_lam map_lam nes arrs [(dummy, intConst Int32 1)] [] + + forM_ (zip (patternNames pat') (patternNames pat)) $ \(from, to) -> do + from_t <- lookupType from + letBindNames_ [to] $ BasicOp $ Index from $ fullSlice from_t [DimFix $ intConst Int32 0] blockedReduction :: (MonadFreshNames m, HasScope Kernels m) => Pattern Kernels diff --git a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs --- a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs +++ b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs @@ -9,7 +9,6 @@ import Control.Arrow (first) import Control.Monad.State -import Data.Semigroup ((<>)) import Futhark.MonadFreshNames import Futhark.Representation.SOACS 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 @@ -191,11 +191,11 @@ -- A GroupScan lambda needs two more parameters. my_index <- newVName "my_index" - other_index <- newVName "other_index" + offset <- newVName "offset" let my_index_param = Param my_index (Prim int32) - other_index_param = Param other_index (Prim int32) + offset_param = Param offset (Prim int32) scanfun'' = scanfun' { lambdaParams = my_index_param : - other_index_param : + offset_param : lambdaParams scanfun' } letBind_ (Pattern [] scan_pes) $ @@ -212,11 +212,11 @@ -- A GroupReduce lambda needs two more parameters. my_index <- newVName "my_index" - other_index <- newVName "other_index" + offset <- newVName "offset" let my_index_param = Param my_index (Prim int32) - other_index_param = Param other_index (Prim int32) + offset_param = Param offset (Prim int32) redfun'' = redfun' { lambdaParams = my_index_param : - other_index_param : + offset_param : lambdaParams redfun' } letBind_ (Pattern [] red_pes) $ diff --git a/src/Futhark/Pass/ExtractKernels/Kernelise.hs b/src/Futhark/Pass/ExtractKernels/Kernelise.hs --- a/src/Futhark/Pass/ExtractKernels/Kernelise.hs +++ b/src/Futhark/Pass/ExtractKernels/Kernelise.hs @@ -14,7 +14,6 @@ where import Control.Monad -import Data.Semigroup ((<>)) import qualified Data.Set as S import qualified Futhark.Analysis.Alias as Alias diff --git a/src/Futhark/Pass/ExtractKernels/Segmented.hs b/src/Futhark/Pass/ExtractKernels/Segmented.hs --- a/src/Futhark/Pass/ExtractKernels/Segmented.hs +++ b/src/Futhark/Pass/ExtractKernels/Segmented.hs @@ -1,15 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} --- | Multiversion segmented reduction. +-- | Segmented scan. module Futhark.Pass.ExtractKernels.Segmented - ( regularSegmentedRedomap - , regularSegmentedScan + ( regularSegmentedScan ) where import Control.Monad import qualified Data.Map.Strict as M -import Data.Semigroup ((<>)) import Futhark.Transform.Rename import Futhark.Representation.Kernels @@ -17,814 +15,6 @@ import Futhark.MonadFreshNames import Futhark.Tools hiding (true, false) import Futhark.Pass.ExtractKernels.BlockedKernel - -data SegmentedVersion = OneGroupOneSegment - | ManyGroupsOneSegment - deriving (Eq, Ord, Show) - --- | @regularSegmentedRedomap@ will generate code for a segmented redomap using --- two different strategies, and dynamically deciding which one to use based on --- the number of segments and segment size. We use the (static) @group_size@ to --- decide which of the following two strategies to choose: --- --- * Large: uses one or more groups to process a single segment. If multiple --- groups are used per segment, the intermediate reduction results must be --- recursively reduced, until there is only a single value per segment. --- --- Each thread /can/ read multiple elements, which will greatly increase --- performance; however, if the reduction is non-commutative the input array --- will be transposed (by the KernelBabysitter) to enable memory coalesced --- accesses. Currently we will always make each thread read as many elements --- as it can, but this /could/ be unfavorable because of the transpose: in --- the case where each thread can only read 2 elements, the cost of the --- transpose might not be worth the performance gained by letting each thread --- read multiple elements. This could be investigated more in depth in the --- future (TODO) --- --- * Small: is used to let each group process *multiple* segments within a --- group. We will only use this approach when we can process at least two --- segments within a single group. In those cases, we would normally allocate --- a /whole/ group per segment with the large strategy, but at most 50% of the --- threads in the group would have any element to read, which becomes highly --- inefficient. -regularSegmentedRedomap :: (HasScope Kernels m, MonadBinder m, Lore m ~ Kernels) => - SubExp -- segment_size - -> SubExp -- num_segments - -> [SubExp] -- nest_sizes = the sizes of the maps on "top" of this redomap - -> Pattern Kernels -- flat_pat ... pat where each type is array with dim [w] - -> Pattern Kernels -- pat - -> SubExp -- w = total_num_elements - -> Commutativity -- comm - -> Lambda InKernel -- reduce_lam - -> Lambda InKernel -- fold_lam = this lambda performs both the map-part and - -- reduce-part of a redomap (described in redomap paper) - -> [(VName, SubExp)] -- ispace = pair of (gtid, size) for the maps on "top" of this redomap - -> [KernelInput] -- inps = inputs that can be looked up by using the gtids from ispace - -> [SubExp] -- nes - -> [VName] -- arrs_flat - -> m () -regularSegmentedRedomap segment_size num_segments nest_sizes flat_pat - pat w comm reduce_lam fold_lam ispace inps nes arrs_flat = do - unless (null $ patternContextElements pat) $ fail "regularSegmentedRedomap result pattern contains context elements, and Rasmus did not think this would ever happen." - - -- the result of the "map" part of a redomap has to be stored somewhere within - -- the chunking loop of a kernel. The current way to do this is to make some - -- scratch space initially, and each thread will get a part of this by - -- splitting it. Finally it is returned as a result of the kernel (to not - -- break functional semantics). - map_out_arrs <- forM (drop num_redres $ patternIdents pat) $ \(Ident name t) -> do - tmp <- letExp (baseString name <> "_out_in") $ - BasicOp $ Scratch (elemType t) (arrayDims t) - -- This reshape will not always work. - letExp (baseString name ++ "_out_in") $ - BasicOp $ Reshape (reshapeOuter [DimNew w] (length nest_sizes+1) $ arrayShape t) tmp - - -- Check that we're only dealing with arrays with dimension [w] - forM_ arrs_flat $ \arr -> do - tp <- lookupType arr - case tp of - -- TODO: this won't work if the reduction operator works on lists... but - -- they seem to be handled in some other way (which makes sense) - Array _primtp (Shape (flatsize:_)) _uniqness -> - when (flatsize /= w) $ - fail$ "regularSegmentedRedomap: first dimension of array has incorrect size " ++ pretty arr ++ ":" ++ pretty tp - _ -> - fail $ "regularSegmentedRedomap: non array encountered " ++ pretty arr ++ ":" ++ pretty tp - - -- The pattern passed to chunkLambda must have exactly *one* array dimension, - -- to get the correct size of [chunk_size]type. - -- - -- TODO: not sure if this will work when result of map is multidimensional, - -- or if reduction operator uses lists... must check - chunk_pat <- fmap (Pattern []) $ forM (patternValueElements pat) $ \pat_e -> - case patElemType pat_e of - Array ty (Shape (dim0:_)) u -> do - vn' <- newName $ patElemName pat_e - return $ PatElem vn' $ Array ty (Shape [dim0]) u - _ -> fail $ "segmentedRedomap: result pattern is not array " ++ pretty pat_e - - chunk_fold_lam <- chunkLambda chunk_pat nes fold_lam - - kern_chunk_fold_lam <- kerneliseLambda nes chunk_fold_lam - - let chunk_red_pat = Pattern [] $ take num_redres $ patternValueElements chunk_pat - kern_chunk_reduce_lam <- kerneliseLambda nes =<< chunkLambda chunk_red_pat nes reduce_lam - - -- the lambda for a GroupReduce needs these two extra parameters - my_index <- newVName "my_index" - other_offset <- newVName "other_offset" - let my_index_param = Param my_index (Prim int32) - let other_offset_param = Param other_offset (Prim int32) - let reduce_lam' = reduce_lam { lambdaParams = my_index_param : - other_offset_param : - lambdaParams reduce_lam - } - flag_reduce_lam <- addFlagToLambda nes reduce_lam - let flag_reduce_lam' = flag_reduce_lam { lambdaParams = my_index_param : - other_offset_param : - lambdaParams flag_reduce_lam - } - - - -- TODO: 'blockedReductionStream' in BlockedKernel.hs which is very similar - -- performs a copy here... however, I have not seen a need for it yet. - - group_size <- getSize "group_size" SizeGroup - num_groups_hint <- getSize "num_groups_hint" SizeNumGroups - - -- Here we make a small optimization: if we will use the large kernel, and - -- only one group per segment, we can simplify the calcualtions within the - -- kernel for the indexes of which segment is it working on; therefore we - -- create two different kernels (this will increase the final code size a bit - -- though). TODO: test how much we win by doing this. - - (num_groups_per_segment, _) <- - calcGroupsPerSegmentAndElementsPerThread - segment_size num_segments num_groups_hint group_size ManyGroupsOneSegment - - let all_arrs = arrs_flat ++ map_out_arrs - (large_1_ses, large_1_stms) <- runBinder $ - useLargeOnePerSeg group_size all_arrs reduce_lam' kern_chunk_fold_lam - (large_m_ses, large_m_stms) <- runBinder $ - useLargeMultiRecursiveReduce group_size all_arrs reduce_lam' kern_chunk_fold_lam - kern_chunk_reduce_lam flag_reduce_lam' - - let e_large_seg = eIf (eCmpOp (CmpEq $ IntType Int32) (eSubExp num_groups_per_segment) - (eSubExp one)) - (mkBodyM large_1_stms large_1_ses) - (mkBodyM large_m_stms large_m_ses) - - - (small_ses, small_stms) <- runBinder $ useSmallKernel group_size map_out_arrs flag_reduce_lam' - - -- if (group_size/2) < segment_size, means that we will not be able to fit two - -- segments into one group, and therefore we should not use the kernel that - -- relies on this. - e <- eIf (eCmpOp (CmpSlt Int32) (eBinOp (SQuot Int32) (eSubExp group_size) (eSubExp two)) - (eSubExp segment_size)) - (eBody [e_large_seg]) - (mkBodyM small_stms small_ses) - - redres_pes <- forM (take num_redres (patternValueElements pat)) $ \pe -> do - vn' <- newName $ patElemName pe - return $ PatElem vn' $ replaceSegmentDims num_segments $ patElemType pe - let mapres_pes = drop num_redres $ patternValueElements flat_pat - let unreshaped_pat = Pattern [] $ redres_pes ++ mapres_pes - - letBind_ unreshaped_pat e - - forM_ (zip (patternValueElements unreshaped_pat) - (patternValueElements pat)) $ \(kpe, pe) -> - letBind_ (Pattern [] [pe]) $ - BasicOp $ Reshape [DimNew se | se <- arrayDims $ patElemAttr pe] - (patElemName kpe) - - where - replaceSegmentDims d t = - t `setArrayDims` (d : drop (length nest_sizes) (arrayDims t)) - - one = constant (1 :: Int32) - two = constant (2 :: Int32) - - -- number of reduction results (tuple size for reduction operator) - num_redres = length nes - - ---------------------------------------------------------------------------- - -- The functions below generate all the needed code for the two different - -- version of segmented-redomap (one group per segment, and many groups per - -- segment). - -- - -- We rename statements before adding them because the same lambdas - -- (reduce/fold) are used multiple times, and we do not want to bind the - -- same VName twice (as this is a type error) - ---------------------------------------------------------------------------- - useLargeOnePerSeg group_size all_arrs reduce_lam' kern_chunk_fold_lam = do - mapres_pes <- forM (drop num_redres $ patternValueElements flat_pat) $ \pe -> do - vn' <- newName $ patElemName pe - return $ PatElem vn' $ patElemType pe - - (kernel, _, _) <- - largeKernel group_size segment_size num_segments nest_sizes - all_arrs comm reduce_lam' kern_chunk_fold_lam - nes w OneGroupOneSegment - ispace inps - - kernel_redres_pes <- forM (take num_redres (patternValueElements pat)) $ \pe -> do - vn' <- newName $ patElemName pe - return $ PatElem vn' $ replaceSegmentDims num_segments $ patElemType pe - - let kernel_pat = Pattern [] $ kernel_redres_pes ++ mapres_pes - - addStm =<< renameStm (Let kernel_pat (defAux ()) $ Op kernel) - return $ map (Var . patElemName) $ patternValueElements kernel_pat - - ---------------------------------------------------------------------------- - useLargeMultiRecursiveReduce group_size all_arrs reduce_lam' kern_chunk_fold_lam kern_chunk_reduce_lam flag_reduce_lam' = do - mapres_pes <- forM (drop num_redres $ patternValueElements flat_pat) $ \pe -> do - vn' <- newName $ patElemName pe - return $ PatElem vn' $ patElemType pe - - (firstkernel, num_groups_used, num_groups_per_segment) <- - largeKernel group_size segment_size num_segments nest_sizes - all_arrs comm reduce_lam' kern_chunk_fold_lam - nes w ManyGroupsOneSegment - ispace inps - - firstkernel_redres_pes <- forM (take num_redres (patternValueElements pat)) $ \pe -> do - vn' <- newName $ patElemName pe - return $ PatElem vn' $ replaceSegmentDims num_groups_used $ patElemType pe - - let first_pat = Pattern [] $ firstkernel_redres_pes ++ mapres_pes - addStm =<< renameStm (Let first_pat (defAux ()) $ Op firstkernel) - - let new_segment_size = num_groups_per_segment - let new_total_elems = num_groups_used - let tmp_redres = map patElemName firstkernel_redres_pes - - (finalredres, part_two_stms) <- runBinder $ performFinalReduction - new_segment_size new_total_elems tmp_redres - reduce_lam' kern_chunk_reduce_lam flag_reduce_lam' - - mapM_ (addStm <=< renameStm) part_two_stms - - return $ finalredres ++ map (Var . patElemName) mapres_pes - - ---------------------------------------------------------------------------- - -- The "recursive" reduction step. However, will always do this using - -- exactly one extra step. Either by using the small kernel, or by using the - -- large kernel with one group per segment. - performFinalReduction new_segment_size new_total_elems tmp_redres - reduce_lam' kern_chunk_reduce_lam flag_reduce_lam' = do - group_size <- getSize "group_size" SizeGroup - - -- Large kernel, using one group per segment (ogps) - (large_ses, large_stms) <- runBinder $ do - (large_kernel, _, _) <- largeKernel group_size new_segment_size num_segments nest_sizes - tmp_redres comm reduce_lam' kern_chunk_reduce_lam - nes new_total_elems OneGroupOneSegment - ispace inps - letTupExp' "kernel_result" $ Op large_kernel - - -- Small kernel, using one group many segments (ogms) - (small_ses, small_stms) <- runBinder $ do - red_scratch_arrs <- forM (take num_redres $ patternIdents pat) $ \(Ident name t) -> do - -- We construct a scratch array for writing the result, but - -- we have to flatten the dimensions corresponding to the - -- map nest, because multi-dimensional WriteReturns are/were - -- not supported. - tmp <- letExp (baseString name <> "_redres_scratch") $ - BasicOp $ Scratch (elemType t) (arrayDims t) - let reshape = reshapeOuter [DimNew num_segments] (length nest_sizes) $ arrayShape t - letExp (baseString name ++ "_redres_scratch") $ - BasicOp $ Reshape reshape tmp - kernel <- smallKernel group_size new_segment_size num_segments - tmp_redres red_scratch_arrs - comm flag_reduce_lam' reduce_lam - nes new_total_elems ispace inps - letTupExp' "kernel_result" $ Op kernel - - e <- eIf (eCmpOp (CmpSlt Int32) - (eBinOp (SQuot Int32) (eSubExp group_size) (eSubExp two)) - (eSubExp new_segment_size)) - (mkBodyM large_stms large_ses) - (mkBodyM small_stms small_ses) - - letTupExp' "step_two_kernel_result" e - - ---------------------------------------------------------------------------- - useSmallKernel group_size map_out_arrs flag_reduce_lam' = do - red_scratch_arrs <- - forM (take num_redres $ patternIdents pat) $ \(Ident name t) -> do - tmp <- letExp (baseString name <> "_redres_scratch") $ - BasicOp $ Scratch (elemType t) (arrayDims t) - let shape_change = reshapeOuter [DimNew num_segments] - (length nest_sizes) (arrayShape t) - letExp (baseString name ++ "_redres_scratch") $ - BasicOp $ Reshape shape_change tmp - - let scratch_arrays = red_scratch_arrs ++ map_out_arrs - - kernel <- smallKernel group_size segment_size num_segments - arrs_flat scratch_arrays - comm flag_reduce_lam' fold_lam - nes w ispace inps - letTupExp' "kernel_result" $ Op kernel - -largeKernel :: (MonadBinder m, Lore m ~ Kernels) => - SubExp -- group_size - -> SubExp -- segment_size - -> SubExp -- num_segments - -> [SubExp] -- nest sizes - -> [VName] -- all_arrs: flat arrays (also the "map_out" ones) - -> Commutativity -- comm - -> Lambda InKernel -- reduce_lam - -> Lambda InKernel -- kern_chunk_fold_lam - -> [SubExp] -- nes - -> SubExp -- w = total_num_elements - -> SegmentedVersion -- segver - -> [(VName, SubExp)] -- ispace = pair of (gtid, size) for the maps on "top" of this redomap - -> [KernelInput] -- inps = inputs that can be looked up by using the gtids from ispace - -> m (Kernel InKernel, SubExp, SubExp) -largeKernel group_size segment_size num_segments nest_sizes all_arrs comm - reduce_lam' kern_chunk_fold_lam - nes w segver ispace inps = do - let num_redres = length nes -- number of reduction results (tuple size for - -- reduction operator) - - num_groups_hint <- getSize "num_groups_hint" SizeNumGroups - - (num_groups_per_segment, elements_per_thread) <- - calcGroupsPerSegmentAndElementsPerThread segment_size num_segments num_groups_hint group_size segver - - num_groups <- letSubExp "num_groups" $ - case segver of - OneGroupOneSegment -> BasicOp $ SubExp num_segments - ManyGroupsOneSegment -> BasicOp $ BinOp (Mul Int32) num_segments num_groups_per_segment - - num_threads <- letSubExp "num_threads" $ - BasicOp $ BinOp (Mul Int32) num_groups group_size - - threads_within_segment <- letSubExp "threads_within_segment" $ - BasicOp $ BinOp (Mul Int32) group_size num_groups_per_segment - - gtid_vn <- newVName "gtid" - gtid_ln <- newVName "gtid" - - -- the array passed here is the structure for how to layout the kernel space - space <- newKernelSpace (num_groups, group_size, num_threads) $ - FlatThreadSpace $ ispace ++ [(gtid_vn, num_groups_per_segment),(gtid_ln,group_size)] - - let red_ts = take num_redres $ lambdaReturnType kern_chunk_fold_lam - let map_ts = map rowType $ drop num_redres $ lambdaReturnType kern_chunk_fold_lam - let kernel_return_types = red_ts ++ map_ts - - let ordering = case comm of Commutative -> SplitStrided threads_within_segment - Noncommutative -> SplitContiguous - - let stride = case ordering of SplitStrided s -> s - SplitContiguous -> one - - let each_thread = do - segment_index <- letSubExp "segment_index" $ - BasicOp $ BinOp (SQuot Int32) (Var $ spaceGroupId space) num_groups_per_segment - - -- localId + (group_size * (groupId % num_groups_per_segment)) - index_within_segment <- letSubExp "index_within_segment" =<< - eBinOp (Add Int32) - (eSubExp $ Var gtid_ln) - (eBinOp (Mul Int32) - (eSubExp group_size) - (eBinOp (SRem Int32) (eSubExp $ Var $ spaceGroupId space) (eSubExp num_groups_per_segment)) - ) - - (in_segment_offset,offset) <- - makeOffsetExp ordering index_within_segment elements_per_thread segment_index - - let (_, chunksize, [], arr_params) = - partitionChunkedKernelFoldParameters 0 $ lambdaParams kern_chunk_fold_lam - let chunksize_se = Var $ paramName chunksize - - patelems_res_of_split <- forM arr_params $ \arr_param -> do - let chunk_t = paramType arr_param `setOuterSize` Var (paramName chunksize) - return $ PatElem (paramName arr_param) chunk_t - - letBind_ (Pattern [] [PatElem (paramName chunksize) $ paramType chunksize]) $ - Op $ SplitSpace ordering segment_size index_within_segment elements_per_thread - - addKernelInputStms inps - - forM_ (zip all_arrs patelems_res_of_split) $ \(arr, pe) -> do - let pe_t = patElemType pe - segment_dims = nest_sizes ++ arrayDims (pe_t `setOuterSize` segment_size) - arr_nested <- letExp (baseString arr ++ "_nested") $ - BasicOp $ Reshape (map DimNew segment_dims) arr - arr_nested_t <- lookupType arr_nested - let slice = fullSlice arr_nested_t $ map (DimFix . Var . fst) ispace ++ - [DimSlice in_segment_offset chunksize_se stride] - letBind_ (Pattern [] [pe]) $ BasicOp $ Index arr_nested slice - - red_pes <- forM red_ts $ \red_t -> do - pe_name <- newVName "chunk_fold_red" - return $ PatElem pe_name red_t - map_pes <- forM map_ts $ \map_t -> do - pe_name <- newVName "chunk_fold_map" - return $ PatElem pe_name $ map_t `arrayOfRow` chunksize_se - - -- we add the lets here, as we practially don't know if the resulting subexp - -- is a Constant or a Var, so better be safe (?) - addStms $ bodyStms (lambdaBody kern_chunk_fold_lam) - addStms $ stmsFromList - [ Let (Pattern [] [pe]) (defAux ()) $ BasicOp $ SubExp se - | (pe,se) <- zip (red_pes ++ map_pes) - (bodyResult $ lambdaBody kern_chunk_fold_lam) ] - - -- Combine the reduction results from each thread. This will put results in - -- local memory, so a GroupReduce can be performed on them - combine_red_pes <- forM red_ts $ \red_t -> do - pe_name <- newVName "chunk_fold_red" - return $ PatElem pe_name $ red_t `arrayOfRow` group_size - cids <- replicateM (length red_pes) $ newVName "cid" - addStms $ stmsFromList - [ Let (Pattern [] [pe']) (defAux ()) $ - Op $ Combine (combineSpace [(cid, group_size)]) [patElemType pe] [] $ - Body () mempty [Var $ patElemName pe] - | (cid, pe', pe) <- zip3 cids combine_red_pes red_pes ] - - final_red_pes <- forM (lambdaReturnType reduce_lam') $ \t -> do - pe_name <- newVName "final_result" - return $ PatElem pe_name t - letBind_ (Pattern [] final_red_pes) $ - Op $ GroupReduce group_size reduce_lam' $ - zip nes (map patElemName combine_red_pes) - - return (final_red_pes, map_pes, offset) - - - ((final_red_pes, map_pes, offset), stms) <- runBinder each_thread - - red_returns <- forM final_red_pes $ \pe -> - return $ ThreadsReturn OneResultPerGroup $ Var $ patElemName pe - map_returns <- forM map_pes $ \pe -> - return $ ConcatReturns ordering w elements_per_thread - (Just offset) $ - patElemName pe - let kernel_returns = red_returns ++ map_returns - - let kerneldebughints = KernelDebugHints kernelname - [ ("num_segment", num_segments) - , ("segment_size", segment_size) - , ("num_groups", num_groups) - , ("group_size", group_size) - , ("elements_per_thread", elements_per_thread) - , ("num_groups_per_segment", num_groups_per_segment) - ] - - let kernel = Kernel kerneldebughints space kernel_return_types $ - KernelBody () stms kernel_returns - - return (kernel, num_groups, num_groups_per_segment) - - where - one = constant (1 :: Int32) - - commname = case comm of Commutative -> "comm" - Noncommutative -> "nocomm" - - kernelname = case segver of - OneGroupOneSegment -> "segmented_redomap__large_" ++ commname ++ "_one" - ManyGroupsOneSegment -> "segmented_redomap__large_" ++ commname ++ "_many" - - makeOffsetExp SplitContiguous index_within_segment elements_per_thread segment_index = do - in_segment_offset <- letSubExp "in_segment_offset" $ - BasicOp $ BinOp (Mul Int32) elements_per_thread index_within_segment - offset <- letSubExp "offset" =<< eBinOp (Add Int32) (eSubExp in_segment_offset) - (eBinOp (Mul Int32) (eSubExp segment_size) (eSubExp segment_index)) - return (in_segment_offset, offset) - makeOffsetExp (SplitStrided _) index_within_segment _elements_per_thread segment_index = do - offset <- letSubExp "offset" =<< eBinOp (Add Int32) (eSubExp index_within_segment) - (eBinOp (Mul Int32) (eSubExp segment_size) (eSubExp segment_index)) - return (index_within_segment, offset) - -calcGroupsPerSegmentAndElementsPerThread :: (MonadBinder m, Lore m ~ Kernels) => - SubExp - -> SubExp - -> SubExp - -> SubExp - -> SegmentedVersion - -> m (SubExp, SubExp) -calcGroupsPerSegmentAndElementsPerThread segment_size num_segments - num_groups_hint group_size segver = do - num_groups_per_segment_hint <- - letSubExp "num_groups_per_segment_hint" =<< - case segver of - OneGroupOneSegment -> eSubExp one - ManyGroupsOneSegment -> eDivRoundingUp Int32 (eSubExp num_groups_hint) - (eSubExp num_segments) - elements_per_thread <- - letSubExp "elements_per_thread" =<< - eDivRoundingUp Int32 (eSubExp segment_size) - (eBinOp (Mul Int32) (eSubExp group_size) - (eSubExp num_groups_per_segment_hint)) - - -- if we are using 1 element per thread, we might be launching too many - -- groups. This expression will remedy this. - -- - -- For example, if there are 3 segments of size 512, we are using group size - -- 128, and @num_groups_hint@ is 256; then we would use 1 element per thread, - -- and launch 256 groups. However, we only need 4 groups per segment to - -- process all elements. - num_groups_per_segment <- - letSubExp "num_groups_per_segment" =<< - case segver of - OneGroupOneSegment -> eSubExp one - ManyGroupsOneSegment -> - eIf (eCmpOp (CmpEq $ IntType Int32) (eSubExp elements_per_thread) (eSubExp one)) - (eBody [eDivRoundingUp Int32 (eSubExp segment_size) (eSubExp group_size)]) - (mkBodyM mempty [num_groups_per_segment_hint]) - - return (num_groups_per_segment, elements_per_thread) - - where - one = constant (1 :: Int32) - -smallKernel :: (MonadBinder m, Lore m ~ Kernels) => - SubExp -- group_size - -> SubExp -- segment_size - -> SubExp -- num_segments - -> [VName] -- in_arrs: flat arrays (containing input to fold_lam) - -> [VName] -- scratch_arrs: Preallocated space that we can write into - -> Commutativity -- comm - -> Lambda InKernel -- flag_reduce_lam' - -> Lambda InKernel -- fold_lam - -> [SubExp] -- nes - -> SubExp -- w = total_num_elements - -> [(VName, SubExp)] -- ispace = pair of (gtid, size) for the maps on "top" of this redomap - -> [KernelInput] -- inps = inputs that can be looked up by using the gtids from ispace - -> m (Kernel InKernel) -smallKernel group_size segment_size num_segments in_arrs scratch_arrs - comm flag_reduce_lam' fold_lam_unrenamed - nes w ispace inps = do - let num_redres = length nes -- number of reduction results (tuple size for - -- reduction operator) - - fold_lam <- renameLambda fold_lam_unrenamed - - num_segments_per_group <- letSubExp "num_segments_per_group" $ - BasicOp $ BinOp (SQuot Int32) group_size segment_size - - num_groups <- letSubExp "num_groups" =<< - eDivRoundingUp Int32 (eSubExp num_segments) (eSubExp num_segments_per_group) - - num_threads <- letSubExp "num_threads" $ - BasicOp $ BinOp (Mul Int32) num_groups group_size - - active_threads_per_group <- letSubExp "active_threads_per_group" $ - BasicOp $ BinOp (Mul Int32) segment_size num_segments_per_group - - let remainder_last_group = eBinOp (SRem Int32) (eSubExp num_segments) (eSubExp num_segments_per_group) - - segments_in_last_group <- letSubExp "seg_in_last_group" =<< - eIf (eCmpOp (CmpEq $ IntType Int32) remainder_last_group - (eSubExp zero)) - (eBody [eSubExp num_segments_per_group]) - (eBody [remainder_last_group]) - - active_threads_in_last_group <- letSubExp "active_threads_last_group" $ - BasicOp $ BinOp (Mul Int32) segment_size segments_in_last_group - - -- the array passed here is the structure for how to layout the kernel space - space <- newKernelSpace (num_groups, group_size, num_threads) $ - FlatThreadSpace [] - - ------------------------------------------------------------------------------ - -- What follows is the statements used in the kernel - ------------------------------------------------------------------------------ - - let lid = Var $ spaceLocalId space - - let (red_ts, map_ts) = splitAt num_redres $ lambdaReturnType fold_lam - let kernel_return_types = red_ts ++ map_ts - - let wasted_thread_part1 = do - let create_dummy_val (Prim ty) = return $ Constant $ blankPrimValue ty - create_dummy_val (Array ty sh _) = letSubExp "dummy" $ BasicOp $ Scratch ty (shapeDims sh) - create_dummy_val Mem{} = fail "segredomap, 'Mem' used as result type" - dummy_vals <- mapM create_dummy_val kernel_return_types - return (negone : dummy_vals) - - let normal_thread_part1 = do - segment_index <- letSubExp "segment_index" =<< - eBinOp (Add Int32) - (eBinOp (SQuot Int32) (eSubExp $ Var $ spaceLocalId space) (eSubExp segment_size)) - (eBinOp (Mul Int32) (eSubExp $ Var $ spaceGroupId space) (eSubExp num_segments_per_group)) - - index_within_segment <- letSubExp "index_within_segment" =<< - eBinOp (SRem Int32) (eSubExp $ Var $ spaceLocalId space) (eSubExp segment_size) - - offset <- makeOffsetExp index_within_segment segment_index - - red_pes <- forM red_ts $ \red_t -> do - pe_name <- newVName "fold_red" - return $ PatElem pe_name red_t - map_pes <- forM map_ts $ \map_t -> do - pe_name <- newVName "fold_map" - return $ PatElem pe_name map_t - - addManualIspaceCalcStms segment_index ispace - - addKernelInputStms inps - - -- Index input array to get arguments to fold_lam - let arr_params = drop num_redres $ lambdaParams fold_lam - let nonred_lamparam_pes = map - (\p -> PatElem (paramName p) (paramType p)) arr_params - forM_ (zip in_arrs nonred_lamparam_pes) $ \(arr, pe) -> do - tp <- lookupType arr - let slice = fullSlice tp [DimFix offset] - letBind_ (Pattern [] [pe]) $ BasicOp $ Index arr slice - - -- Bind neutral element (serves as the reduction arguments to fold_lam) - forM_ (zip nes (take num_redres $ lambdaParams fold_lam)) $ \(ne,param) -> do - let pe = PatElem (paramName param) (paramType param) - letBind_ (Pattern [] [pe]) $ BasicOp $ SubExp ne - - addStms $ bodyStms $ lambdaBody fold_lam - - -- we add the lets here, as we practially don't know if the resulting subexp - -- is a Constant or a Var, so better be safe (?) - addStms $ stmsFromList - [ Let (Pattern [] [pe]) (defAux ()) $ BasicOp $ SubExp se - | (pe,se) <- zip (red_pes ++ map_pes) (bodyResult $ lambdaBody fold_lam) ] - - let mapoffset = offset - let mapret_elems = map (Var . patElemName) map_pes - let redres_elems = map (Var . patElemName) red_pes - return (mapoffset : redres_elems ++ mapret_elems) - - let all_threads red_pes = do - isfirstinsegment <- letExp "isfirstinsegment" =<< - eCmpOp (CmpEq $ IntType Int32) - (eBinOp (SRem Int32) (eSubExp lid) (eSubExp segment_size)) - (eSubExp zero) - - -- We will perform a segmented-scan, so all the prime variables here - -- include the flag, which is the first argument to flag_reduce_lam - let red_pes_wflag = PatElem isfirstinsegment (Prim Bool) : red_pes - let red_ts_wflag = Prim Bool : red_ts - - -- Combine the reduction results from each thread. This will put results in - -- local memory, so a GroupReduce/GroupScan can be performed on them - combine_red_pes' <- forM red_ts_wflag $ \red_t -> do - pe_name <- newVName "chunk_fold_red" - return $ PatElem pe_name $ red_t `arrayOfRow` group_size - cids <- replicateM (length red_pes_wflag) $ newVName "cid" - addStms $ stmsFromList [ Let (Pattern [] [pe']) (defAux ()) $ Op $ - Combine (combineSpace [(cid, group_size)]) [patElemType pe] [] $ - Body () mempty [Var $ patElemName pe] - | (cid, pe', pe) <- zip3 cids combine_red_pes' red_pes_wflag ] - - scan_red_pes_wflag <- forM red_ts_wflag $ \red_t -> do - pe_name <- newVName "scanned" - return $ PatElem pe_name $ red_t `arrayOfRow` group_size - let scan_red_pes = drop 1 scan_red_pes_wflag - letBind_ (Pattern [] scan_red_pes_wflag) $ Op $ - GroupScan group_size flag_reduce_lam' $ - zip (false:nes) (map patElemName combine_red_pes') - - return scan_red_pes - - let normal_thread_part2 scan_red_pes = do - segment_index <- letSubExp "segment_index" =<< - eBinOp (Add Int32) - (eBinOp (SQuot Int32) (eSubExp $ Var $ spaceLocalId space) (eSubExp segment_size)) - (eBinOp (Mul Int32) (eSubExp $ Var $ spaceGroupId space) (eSubExp num_segments_per_group)) - - islastinsegment <- letExp "islastinseg" =<< eCmpOp (CmpEq $ IntType Int32) - (eBinOp (SRem Int32) (eSubExp lid) (eSubExp segment_size)) - (eBinOp (Sub Int32) (eSubExp segment_size) (eSubExp one)) - - redoffset <- letSubExp "redoffset" =<< - eIf (eSubExp $ Var islastinsegment) - (eBody [eSubExp segment_index]) - (mkBodyM mempty [negone]) - - redret_elems <- fmap (map Var) $ letTupExp "red_return_elem" =<< - eIf (eSubExp $ Var islastinsegment) - (eBody [return $ BasicOp $ Index (patElemName pe) (fullSlice (patElemType pe) [DimFix lid]) - | pe <- scan_red_pes]) - (mkBodyM mempty nes) - - return (redoffset : redret_elems) - - - let picknchoose = do - is_last_group <- letSubExp "islastgroup" =<< - eCmpOp (CmpEq $ IntType Int32) - (eSubExp $ Var $ spaceGroupId space) - (eBinOp (Sub Int32) (eSubExp num_groups) (eSubExp one)) - - active_threads_this_group <- letSubExp "active_thread_this_group" =<< - eIf (eSubExp is_last_group) - (eBody [eSubExp active_threads_in_last_group]) - (eBody [eSubExp active_threads_per_group]) - - isactive <- letSubExp "isactive" =<< - eCmpOp (CmpSlt Int32) (eSubExp lid) (eSubExp active_threads_this_group) - - -- Part 1: All active threads reads element from input array and applies - -- folding function. "wasted" threads will just create dummy values - (normal_res1, normal_stms1) <- runBinder normal_thread_part1 - (wasted_res1, wasted_stms1) <- runBinder wasted_thread_part1 - - -- we could just have used letTupExp, but this would not give as nice - -- names in the generated code - mapoffset_pe <- (`PatElem` i32) <$> newVName "mapoffset" - redtmp_pes <- forM red_ts $ \red_t -> do - pe_name <- newVName "redtmp_res" - return $ PatElem pe_name red_t - map_pes <- forM map_ts $ \map_t -> do - pe_name <- newVName "map_res" - return $ PatElem pe_name map_t - - e1 <- eIf (eSubExp isactive) - (mkBodyM normal_stms1 normal_res1) - (mkBodyM wasted_stms1 wasted_res1) - letBind_ (Pattern [] (mapoffset_pe:redtmp_pes++map_pes)) e1 - - -- Part 2: All threads participate in Comine & GroupScan - scan_red_pes <- all_threads redtmp_pes - - -- Part 3: Active thread that are the last element in segment, should - -- write the element from local memory to the output array - (normal_res2, normal_stms2) <- runBinder $ normal_thread_part2 scan_red_pes - - redoffset_pe <- (`PatElem` i32) <$> newVName "redoffset" - red_pes <- forM red_ts $ \red_t -> do - pe_name <- newVName "red_res" - return $ PatElem pe_name red_t - - e2 <- eIf (eSubExp isactive) - (mkBodyM normal_stms2 normal_res2) - (mkBodyM mempty (negone : nes)) - letBind_ (Pattern [] (redoffset_pe:red_pes)) e2 - - return $ map (Var . patElemName) $ redoffset_pe:mapoffset_pe:red_pes++map_pes - - (redoffset:mapoffset:redmapres, stms) <- runBinder picknchoose - let (finalredvals, finalmapvals) = splitAt num_redres redmapres - - -- To be able to only return elements from some threads, we exploit the fact - -- that WriteReturn with offset=-1, won't do anything. - red_returns <- forM (zip finalredvals $ take num_redres scratch_arrs) $ \(se, scarr) -> - return $ WriteReturn [num_segments] scarr [([redoffset], se)] - map_returns <- forM (zip finalmapvals $ drop num_redres scratch_arrs) $ \(se, scarr) -> - return $ WriteReturn [w] scarr [([mapoffset], se)] - let kernel_returns = red_returns ++ map_returns - - let kerneldebughints = KernelDebugHints kernelname - [ ("num_segment", num_segments) - , ("segment_size", segment_size) - , ("num_groups", num_groups) - , ("group_size", group_size) - , ("num_segments_per_group", num_segments_per_group) - , ("active_threads_per_group", active_threads_per_group) - ] - - let kernel = Kernel kerneldebughints space kernel_return_types $ - KernelBody () stms kernel_returns - - return kernel - - where - i32 = Prim $ IntType Int32 - zero = constant (0 :: Int32) - one = constant (1 :: Int32) - negone = constant (-1 :: Int32) - false = constant False - - - commname = case comm of Commutative -> "comm" - Noncommutative -> "nocomm" - kernelname = "segmented_redomap__small_" ++ commname - - makeOffsetExp index_within_segment segment_index = do - e <- eBinOp (Add Int32) - (eSubExp index_within_segment) - (eBinOp (Mul Int32) (eSubExp segment_size) (eSubExp segment_index)) - letSubExp "offset" e - -addKernelInputStms :: (MonadBinder m, Lore m ~ InKernel) => - [KernelInput] - -> m () -addKernelInputStms = mapM_ $ \kin -> do - let pe = PatElem (kernelInputName kin) (kernelInputType kin) - let arr = kernelInputArray kin - arrtp <- lookupType arr - let slice = fullSlice arrtp [DimFix se | se <- kernelInputIndices kin] - letBind (Pattern [] [pe]) $ BasicOp $ Index arr slice - --- | Manually calculate the values for the ispace identifiers, when the --- 'SpaceStructure' won't do. ispace is the dimensions of the overlaying maps. --- --- If the input is @i [(a_vn, a), (b_vn, b), (c_vn, c)]@ then @i@ should hit all --- the values [0,a*b*c). We can calculate the indexes for the other dimensions: --- --- > c_vn = i % c --- > b_vn = (i/c) % b --- > a_vn = ((i/c)/b) % a -addManualIspaceCalcStms :: (MonadBinder m, Lore m ~ InKernel) => - SubExp - -> [(VName, SubExp)] - -> m () -addManualIspaceCalcStms outer_index ispace = do - -- TODO: The ispace index is calculated in a bit different way than it - -- would have been done if the ThreadSpace was used. However, this - -- works. Maybe ask Troels if doing it the other way has some benefit? - let calc_ispace_index prev_val (vn,size) = do - let pe = PatElem vn (Prim $ IntType Int32) - letBind_ (Pattern [] [pe]) $ BasicOp $ BinOp (SRem Int32) prev_val size - letSubExp "tmp_val" $ BasicOp $ BinOp (SQuot Int32) prev_val size - foldM_ calc_ispace_index outer_index (reverse ispace) addFlagToLambda :: (MonadBinder m, Lore m ~ Kernels) => [SubExp] -> Lambda InKernel -> m (Lambda InKernel) diff --git a/src/Futhark/Pass/ExtractKernels/Split.hs b/src/Futhark/Pass/ExtractKernels/Split.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Pass/ExtractKernels/Split.hs @@ -0,0 +1,41 @@ +-- | Functionality for identifying chunks of interesting parallelism +-- inside of a map nesting. +module Futhark.Pass.ExtractKernels.Split + ( splitMap) where + +import Control.Monad.RWS.Strict +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Maybe +import Data.List +import qualified Data.Semigroup as Sem + +import Futhark.Representation.SOACS +import Futhark.Representation.SOACS.Simplify (simplifyStms, simpleSOACS) +import qualified Futhark.Representation.Kernels as Out +import Futhark.Representation.Kernels.Kernel +import Futhark.MonadFreshNames +import Futhark.Tools +import qualified Futhark.Transform.FirstOrderTransform as FOT +import qualified Futhark.Pass.ExtractKernels.Kernelise as Kernelise +import Futhark.Transform.Rename +import Futhark.Pass +import Futhark.Transform.CopyPropagate +import Futhark.Pass.ExtractKernels.Distribution +import Futhark.Pass.ExtractKernels.ISRWIM +import Futhark.Pass.ExtractKernels.BlockedKernel +import Futhark.Pass.ExtractKernels.Segmented +import Futhark.Pass.ExtractKernels.Interchange +import Futhark.Pass.ExtractKernels.Intragroup +import Futhark.Util +import Futhark.Util.Log + +type KernelsStms = Out.Stms Out.Kernels +type InKernelStms = Out.Stms Out.InKernel +type InKernelLambda = Out.Lambda Out.InKernel + +splitMap :: (MonadFreshNames m) => + Scope SOACS -> a -> m [a] +splitMap scope loop = return [loop] 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 @@ -14,7 +14,6 @@ import Data.Foldable import Data.List import Data.Maybe -import Data.Semigroup ((<>)) import Futhark.MonadFreshNames import Futhark.Representation.AST 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 @@ -25,7 +25,6 @@ import qualified Data.Text as T import qualified Data.ByteString as BS import qualified Data.Text.Encoding as T -import qualified Data.Semigroup as Sem import Data.List import Data.Monoid ((<>)) import qualified System.FilePath.Posix as Posix @@ -255,12 +254,11 @@ -- monoidically. In essence, the PkgRegistry is just a cache. newtype PkgRegistry m = PkgRegistry (M.Map PkgPath (PkgInfo m)) -instance Sem.Semigroup (PkgRegistry m) where +instance Semigroup (PkgRegistry m) where PkgRegistry x <> PkgRegistry y = PkgRegistry $ x <> y instance Monoid (PkgRegistry m) where mempty = PkgRegistry mempty - mappend = (Sem.<>) lookupKnownPackage :: PkgPath -> PkgRegistry m -> Maybe (PkgInfo m) lookupKnownPackage p (PkgRegistry m) = M.lookup p m 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 @@ -42,8 +42,6 @@ import Data.Maybe import Data.Traversable import Data.Void -import Data.Semigroup ((<>)) -import qualified Data.Semigroup as Sem import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Map as M @@ -102,12 +100,11 @@ newtype PkgRevDeps = PkgRevDeps (M.Map PkgPath (SemVer, Maybe T.Text)) deriving (Show) -instance Sem.Semigroup PkgRevDeps where +instance Semigroup PkgRevDeps where PkgRevDeps x <> PkgRevDeps y = PkgRevDeps $ x <> y instance Monoid PkgRevDeps where mempty = PkgRevDeps mempty - mappend = (Sem.<>) --- Package manifest diff --git a/src/Futhark/Representation/AST/Attributes/TypeOf.hs b/src/Futhark/Representation/AST/Attributes/TypeOf.hs --- a/src/Futhark/Representation/AST/Attributes/TypeOf.hs +++ b/src/Futhark/Representation/AST/Attributes/TypeOf.hs @@ -38,7 +38,6 @@ where import Data.Maybe -import Data.Semigroup ((<>)) import Data.Foldable import qualified Data.Set as S diff --git a/src/Futhark/Representation/AST/Syntax.hs b/src/Futhark/Representation/AST/Syntax.hs --- a/src/Futhark/Representation/AST/Syntax.hs +++ b/src/Futhark/Representation/AST/Syntax.hs @@ -69,7 +69,6 @@ import Data.Foldable import Data.Loc import qualified Data.Sequence as Seq -import qualified Data.Semigroup as Sem import Language.Futhark.Core import Futhark.Representation.AST.Annotations @@ -90,12 +89,11 @@ instance Functor PatternT where fmap f (Pattern ctx val) = Pattern (map (fmap f) ctx) (map (fmap f) val) -instance Sem.Semigroup (PatternT attr) where +instance Semigroup (PatternT attr) where Pattern cs1 vs1 <> Pattern cs2 vs2 = Pattern (cs1++cs2) (vs1++vs2) instance Monoid (PatternT attr) where mempty = Pattern [] [] - mappend = (Sem.<>) -- | A type alias for namespace control. type Pattern lore = PatternT (LetAttr lore) @@ -152,14 +150,20 @@ -- | The new dimension in a 'Reshape'-like operation. This allows us to -- disambiguate "real" reshapes, that change the actual shape of the -- array, from type coercions that are just present to make the types --- work out. +-- work out. The two constructors are considered equal for purposes of 'Eq'. data DimChange d = DimCoercion d -- ^ The new dimension is guaranteed to be numerically -- equal to the old one. | DimNew d -- ^ The new dimension is not necessarily numerically -- equal to the old one. - deriving (Eq, Ord, Show) + deriving (Ord, Show) + +instance Eq d => Eq (DimChange d) where + DimCoercion x == DimNew y = x == y + DimCoercion x == DimCoercion y = x == y + DimNew x == DimCoercion y = x == y + DimNew x == DimNew y = x == y instance Functor DimChange where fmap f (DimCoercion d) = DimCoercion $ f d 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 @@ -59,7 +59,6 @@ import Data.String import qualified Data.Set as S import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import Data.Traversable import Language.Futhark.Core @@ -101,12 +100,11 @@ -- | Check whether one shape if a subset of another shape. subShapeOf :: a -> a -> Bool -instance Sem.Semigroup (ShapeBase d) where +instance Semigroup (ShapeBase d) where Shape l1 <> Shape l2 = Shape $ l1 `mappend` l2 instance Monoid (ShapeBase d) where mempty = Shape mempty - mappend = (Sem.<>) instance Functor ShapeBase where fmap f = Shape . map f . shapeDims @@ -135,12 +133,11 @@ Nothing -> do put $ M.insert y x extmap return True -instance Sem.Semigroup Rank where +instance Semigroup Rank where Rank x <> Rank y = Rank $ x + y instance Monoid Rank where mempty = Rank 0 - mappend = (Sem.<>) instance ArrayShape Rank where shapeRank (Rank x) = x @@ -214,12 +211,11 @@ newtype Certificates = Certificates { unCertificates :: [VName] } deriving (Eq, Ord, Show) -instance Sem.Semigroup Certificates where +instance Semigroup Certificates where Certificates x <> Certificates y = Certificates (x <> y) instance Monoid Certificates where mempty = Certificates mempty - mappend = (Sem.<>) -- | A subexpression is either a scalar constant or a variable. One -- important property is that evaluation of a subexpression is 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 @@ -46,7 +46,6 @@ import Data.Monoid ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified Data.Semigroup as Sem import Futhark.Representation.AST.Syntax import Futhark.Representation.AST.Attributes @@ -68,12 +67,11 @@ newtype Names' = Names' { unNames :: Names } deriving (Show) -instance Sem.Semigroup Names' where +instance Semigroup Names' where x <> y = Names' $ unNames x <> unNames y instance Monoid Names' where mempty = Names' mempty - mappend = (Sem.<>) instance Eq Names' where _ == _ = True diff --git a/src/Futhark/Representation/ExplicitMemory/Simplify.hs b/src/Futhark/Representation/ExplicitMemory/Simplify.hs --- a/src/Futhark/Representation/ExplicitMemory/Simplify.hs +++ b/src/Futhark/Representation/ExplicitMemory/Simplify.hs @@ -12,7 +12,6 @@ import Control.Monad import qualified Data.Set as S -import Data.Semigroup ((<>)) import Data.Maybe import Data.List 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 @@ -80,11 +80,14 @@ deriving (Eq, Show, Ord) data Kernel lore = - GetSize VName SizeClass -- ^ Produce some runtime-configurable size. + GetSize Name SizeClass -- ^ Produce some runtime-configurable size. | GetSizeMax SizeClass -- ^ The maximum size of some class. - | CmpSizeLe VName SizeClass SubExp + | CmpSizeLe Name SizeClass SubExp -- ^ Compare size (likely a threshold) with some Int32 value. | Kernel KernelDebugHints KernelSpace [Type] (KernelBody lore) + | SegRed KernelSpace Commutativity (Lambda lore) [SubExp] [Type] (Body lore) + -- ^ The KernelSpace must always have at least two dimensions, + -- implying that the result of a SegRed is always an array. deriving (Eq, Show, Ord) data KernelSpace = KernelSpace { spaceGlobalId :: VName @@ -189,28 +192,39 @@ pure $ GetSizeMax size_class mapKernelM tv (CmpSizeLe name size_class x) = CmpSizeLe name size_class <$> mapOnKernelSubExp tv x +mapKernelM tv (SegRed space comm red_op nes ts lam) = + SegRed + <$> mapOnKernelSpace tv space + <*> pure comm + <*> mapOnKernelLambda tv red_op + <*> mapM (mapOnKernelSubExp tv) nes + <*> mapM (mapOnType $ mapOnKernelSubExp tv) ts + <*> mapOnKernelBody tv lam mapKernelM tv (Kernel desc space ts kernel_body) = Kernel <$> mapOnKernelDebugHints desc <*> - mapOnKernelSpace space <*> + mapOnKernelSpace tv space <*> mapM (mapOnKernelType tv) ts <*> mapOnKernelKernelBody tv kernel_body where mapOnKernelDebugHints (KernelDebugHints name kvs) = KernelDebugHints name <$> (zip (map fst kvs) <$> mapM (mapOnKernelSubExp tv . snd) kvs) - mapOnKernelSpace (KernelSpace gtid ltid gid num_threads num_groups group_size structure) = - KernelSpace gtid ltid gid -- all in binding position - <$> mapOnKernelSubExp tv num_threads - <*> mapOnKernelSubExp tv num_groups - <*> mapOnKernelSubExp tv group_size - <*> mapOnKernelStructure structure - mapOnKernelStructure (FlatThreadSpace dims) = + +mapOnKernelSpace :: Monad f => + KernelMapper flore tlore f -> KernelSpace -> f KernelSpace +mapOnKernelSpace tv (KernelSpace gtid ltid gid num_threads num_groups group_size structure) = + KernelSpace gtid ltid gid -- all in binding position + <$> mapOnKernelSubExp tv num_threads + <*> mapOnKernelSubExp tv num_groups + <*> mapOnKernelSubExp tv group_size + <*> mapOnKernelStructure structure + where mapOnKernelStructure (FlatThreadSpace dims) = FlatThreadSpace <$> (zip gtids <$> mapM (mapOnKernelSubExp tv) gdim_sizes) where (gtids, gdim_sizes) = unzip dims mapOnKernelStructure (NestedThreadSpace dims) = - NestedThreadSpace <$> (zip4 gtids - <$> mapM (mapOnKernelSubExp tv) gdim_sizes - <*> pure ltids - <*> mapM (mapOnKernelSubExp tv) ldim_sizes) + NestedThreadSpace <$> (zip4 gtids + <$> mapM (mapOnKernelSubExp tv) gdim_sizes + <*> pure ltids + <*> mapM (mapOnKernelSubExp tv) ldim_sizes) where (gtids, gdim_sizes, ltids, ldim_sizes) = unzip4 dims mapOnKernelType :: Monad m => @@ -400,6 +414,13 @@ resultShape t KernelInPlaceReturn{} = t +kernelType (SegRed space _ _ nes ts _) = + map (`arrayOfShape` Shape outer_dims) red_ts ++ + map (`arrayOfShape` Shape dims) map_ts + where (red_ts, map_ts) = splitAt (length nes) ts + dims = map snd $ spaceDimensions space + outer_dims = init dims + kernelType GetSize{} = [Prim int32] kernelType GetSizeMax{} = [Prim int32] kernelType CmpSizeLe{} = [Prim Bool] @@ -544,6 +565,8 @@ instance Aliased lore => UsageInOp (Kernel lore) where usageInOp (Kernel _ _ _ kbody) = mconcat $ map UT.consumedUsage $ S.toList $ consumedInKernelBody kbody + usageInOp (SegRed _ _ _ _ _ body) = + mconcat $ map UT.consumedUsage $ S.toList $ consumedInBody body usageInOp GetSize{} = mempty usageInOp GetSizeMax{} = mempty usageInOp CmpSizeLe{} = mempty @@ -559,6 +582,22 @@ typeCheckKernel GetSizeMax{} = return () typeCheckKernel (CmpSizeLe _ _ x) = TC.require [Prim int32] x +typeCheckKernel (SegRed space _ red_op nes ts body) = do + checkSpace space + mapM_ TC.checkType ts + + ne_ts <- mapM subExpType nes + + let asArg t = (t, mempty) + TC.binding (scopeOfKernelSpace space) $ do + TC.checkLambda red_op $ map asArg $ ne_ts ++ ne_ts + unless (lambdaReturnType red_op == ne_ts && + take (length nes) ts == ne_ts) $ + TC.bad $ TC.TypeError + "SegRed: wrong type for reduction or neutral elements." + + TC.checkLambdaBody ts body + typeCheckKernel (Kernel _ space kts kbody) = do checkSpace space mapM_ TC.checkType kts @@ -566,16 +605,7 @@ TC.binding (scopeOfKernelSpace space) $ checkKernelBody kts kbody - where checkSpace (KernelSpace _ _ _ num_threads num_groups group_size structure) = do - mapM_ (TC.require [Prim int32]) [num_threads,num_groups,group_size] - case structure of - FlatThreadSpace dims -> - mapM_ (TC.require [Prim int32] . snd) dims - NestedThreadSpace dims -> - let (_, gdim_sizes, _, ldim_sizes) = unzip4 dims - in mapM_ (TC.require [Prim int32]) $ gdim_sizes ++ ldim_sizes - - checkKernelBody ts (KernelBody (_, attr) stms res) = do + where checkKernelBody ts (KernelBody (_, attr) stms res) = do TC.checkBodyLore attr TC.checkStms stms $ do unless (length ts == length res) $ @@ -617,11 +647,23 @@ mapM_ (TC.requireI [Prim int32] . fst) limit mapM_ (TC.require [Prim int32] . snd) limit +checkSpace :: TC.Checkable lore => KernelSpace -> TC.TypeM lore () +checkSpace (KernelSpace _ _ _ num_threads num_groups group_size structure) = do + mapM_ (TC.require [Prim int32]) [num_threads,num_groups,group_size] + case structure of + FlatThreadSpace dims -> + mapM_ (TC.require [Prim int32] . snd) dims + NestedThreadSpace dims -> + let (_, gdim_sizes, _, ldim_sizes) = unzip4 dims + in mapM_ (TC.require [Prim int32]) $ gdim_sizes ++ ldim_sizes + instance OpMetrics (Op lore) => OpMetrics (Kernel lore) where opMetrics (Kernel _ _ _ kbody) = inside "Kernel" $ kernelBodyMetrics kbody where kernelBodyMetrics :: KernelBody lore -> MetricsM () kernelBodyMetrics = mapM_ bindingMetrics . kernelBodyStms + opMetrics (SegRed _ _ red_op _ _ body) = + inside "SegRed" $ lambdaMetrics red_op >> bodyMetrics body opMetrics GetSize{} = seen "GetSize" opMetrics GetSizeMax{} = seen "GetSizeMax" opMetrics CmpSizeLe{} = seen "CmpSizeLe" @@ -641,6 +683,14 @@ text "kernel" <+> text (kernelName desc) <> PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> PP.nestedBlock "{" "}" (ppr body) + + ppr (SegRed space comm red_op nes ts body) = + text name <> PP.parens (ppr red_op <> PP.comma + PP.braces (PP.commasep $ map ppr nes)) + PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> + PP.nestedBlock "{" "}" (ppr body) + where name = case comm of Commutative -> "segred_comm" + Noncommutative -> "segred" instance Pretty KernelSpace where ppr (KernelSpace f_gtid f_ltid gid num_threads num_groups group_size structure) = 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 @@ -19,7 +19,6 @@ import Data.Foldable import Data.List import Data.Maybe -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -77,6 +76,37 @@ kbody_hoisted' <- mapM processHoistedStm kbody_hoisted return (Kernel desc space' ts' $ mkWiseKernelBody () kbody_stms kbody_res, kbody_hoisted') + where scope = scopeOfKernelSpace space + scope_vtable = ST.fromScope scope + bound_here = S.fromList $ M.keys scope + +simplifyKernelOp mk_ops env (SegRed space comm red_op nes ts body) = do + space' <- Engine.simplify space + nes' <- mapM Engine.simplify nes + ts' <- mapM Engine.simplify ts + outer_vtable <- Engine.askVtable + + (red_op', red_op_hoisted) <- + Engine.subSimpleM (mk_ops space) env outer_vtable $ + Engine.localVtable (<>scope_vtable) $ + Engine.simplifyLambda red_op $ replicate (length nes * 2) Nothing + red_op_hoisted' <- mapM processHoistedStm red_op_hoisted + + ((body_stms, body_res), body_hoisted) <- + Engine.subSimpleM (mk_ops space) env outer_vtable $ do + par_blocker <- Engine.asksEngineEnv $ Engine.blockHoistPar . Engine.envHoistBlockers + Engine.localVtable (<>scope_vtable) $ + Engine.blockIf (Engine.hasFree bound_here + `Engine.orIf` Engine.isOp + `Engine.orIf` par_blocker + `Engine.orIf` Engine.isConsumed) $ + Engine.simplifyBody (replicate (length ts) Observe) body + body_hoisted' <- mapM processHoistedStm body_hoisted + + return (SegRed space' comm red_op' nes' ts' $ + mkWiseBody () body_stms body_res, + red_op_hoisted' <> body_hoisted') + where scope_vtable = ST.fromScope scope scope = scopeOfKernelSpace space bound_here = S.fromList $ M.keys scope diff --git a/src/Futhark/Representation/Kernels/Sizes.hs b/src/Futhark/Representation/Kernels/Sizes.hs --- a/src/Futhark/Representation/Kernels/Sizes.hs +++ b/src/Futhark/Representation/Kernels/Sizes.hs @@ -3,12 +3,12 @@ where import Futhark.Util.Pretty -import Language.Futhark.Core (VName) +import Language.Futhark.Core (Name) import Futhark.Representation.AST.Pretty () -- | An indication of which comparisons have been performed to get to -- this point, as well as the result of each comparison. -type KernelPath = [(VName, Bool)] +type KernelPath = [(Name, Bool)] -- | The class of some kind of configurable size. Each class may -- impose constraints on the valid values. 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 @@ -18,7 +18,6 @@ import Data.Either import Data.List import Data.Maybe -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} -- | Facilities for reading Futhark test programs. A Futhark test -- program is an ordinary Futhark program where an initial comment -- block specifies input- and output-sets. @@ -9,6 +11,12 @@ , getValues , getValuesBS , compareValues + , compareValues1 + , testRunReferenceOutput + , getExpectedResult + , compileProgram + , runProgram + , ensureReferenceOutput , Mismatch , ProgramTest (..) @@ -20,6 +28,7 @@ , InputOutputs (..) , TestRun (..) , ExpectedResult (..) + , Success(..) , Values (..) , GenValue (..) , Value @@ -31,14 +40,13 @@ import qualified Data.ByteString as SBS import Control.Exception (catch) import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.Except import qualified Data.Map.Strict as M import Data.Char import Data.Functor import Data.Maybe import Data.Foldable (foldl') import Data.List -import Data.Semigroup import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T @@ -54,15 +62,16 @@ import System.Directory import System.Exit import System.Process.ByteString (readProcessWithExitCode) -import System.IO (withFile, IOMode(..), hFileSize) +import System.IO (withFile, IOMode(..), hFileSize, hClose) import System.IO.Error +import System.IO.Temp import Prelude import Futhark.Analysis.Metrics import Futhark.Representation.Primitive (IntType(..), FloatType(..), intByteSize, floatByteSize) import Futhark.Test.Values -import Futhark.Util (directoryContents) +import Futhark.Util (directoryContents, pmapIO) import Futhark.Util.Pretty (pretty, prettyText) import Language.Futhark.Syntax (PrimType(..), Int32) @@ -120,7 +129,7 @@ data TestRun = TestRun { runTags :: [String] , runInput :: Values - , runExpectedResult :: ExpectedResult Values + , runExpectedResult :: ExpectedResult Success , runIndex :: Int , runDescription :: String } @@ -155,6 +164,14 @@ | RunTimeFailure ExpectedError -- ^ Execution fails with this error. deriving (Show) +-- | The result expected from a succesful execution. +data Success = SuccessValues Values + -- ^ These values are expected. + | SuccessGenerateValues + -- ^ Compute expected values from executing a known-good + -- reference implementation. + deriving (Show) + type Parser = Parsec Void T.Text lexeme :: Parser a -> Parser a @@ -221,7 +238,9 @@ parseRunCase i = do tags <- parseRunTags lexstr "input" - input <- if "random" `elem` tags then parseRandomValues else parseValues + input <- if "random" `elem` tags + then parseRandomValues + else parseValues expr <- parseExpectedResult return $ TestRun tags input expr i $ desc i input @@ -242,9 +261,10 @@ desc _ (GenValues gens) = unwords $ map genValueType gens -parseExpectedResult :: Parser (ExpectedResult Values) +parseExpectedResult :: Parser (ExpectedResult Success) parseExpectedResult = - (Succeeds . Just <$> (lexstr "output" *> parseValues)) <|> + (lexstr "auto" *> lexstr "output" $> Succeeds (Just SuccessGenerateValues)) <|> + (Succeeds . Just . SuccessValues <$> (lexstr "output" *> parseValues)) <|> (RunTimeFailure <$> (lexstr "error:" *> parseExpectedError)) <|> pure (Succeeds Nothing) @@ -461,16 +481,29 @@ getValuesBS dir (GenValues gens) = mconcat <$> mapM (getGenBS dir) gens +-- | There is a risk of race conditions when multiple programs have +-- identical 'GenValues'. In such cases, multiple threads in 'futhark +-- test' might attempt to create the same file (or read from it, while +-- something else is constructing it). This leads to a mess. To +-- avoid this, we create a temporary file, and only when it is +-- complete do we move it into place. It would be better if we could +-- use file locking, but that does not work on some file systems. The +-- approach here seems robust enough for now, but certainly it could +-- be made even better. The race condition that remains should mostly +-- result in duplicate work, not crashes or data corruption. getGenBS :: MonadIO m => FilePath -> GenValue -> m BS.ByteString getGenBS dir gen = do + liftIO $ createDirectoryIfMissing True $ dir "data" exists_and_proper_size <- liftIO $ withFile (dir file) ReadMode (fmap (== genFileSize gen) . hFileSize) `catch` \ex -> if isDoesNotExistError ex then return False else E.throw ex unless exists_and_proper_size $ liftIO $ do s <- genValues [gen] - createDirectoryIfMissing True $ takeDirectory $ dir file - SBS.writeFile (dir file) s + withTempFile (dir "data") (genFileName gen) $ \tmpfile h -> do + hClose h -- We will be writing and reading this ourselves. + SBS.writeFile tmpfile s + renameFile tmpfile $ dir file getValuesBS dir $ InFile file where file = "data" genFileName gen @@ -501,3 +534,94 @@ primSize (Unsigned it) = intByteSize it primSize (FloatType ft) = floatByteSize ft primSize Bool = 1 + +-- | When/if generating a reference output file for this run, what +-- should it be called? Includes the "data/" folder. +testRunReferenceOutput :: FilePath -> T.Text -> TestRun -> FilePath +testRunReferenceOutput prog entry tr = + "data" + takeBaseName prog + <> ":" <> T.unpack entry + <> "-" <> map clean (runDescription tr) + <.> "out" + where clean '/' = '_' -- Would this ever happen? + clean ' ' = '_' + clean c = c + +-- | Get the values corresponding to an expected result, if any. +getExpectedResult :: MonadIO m => + FilePath -> T.Text -> TestRun + -> m (ExpectedResult [Value]) +getExpectedResult prog entry tr = + case runExpectedResult tr of + (Succeeds (Just (SuccessValues vals))) -> + Succeeds . Just <$> getValues (takeDirectory prog) vals + Succeeds (Just SuccessGenerateValues) -> + getExpectedResult prog entry + tr { runExpectedResult = Succeeds $ Just $ SuccessValues $ InFile $ + testRunReferenceOutput prog entry tr } + Succeeds Nothing -> + return $ Succeeds Nothing + RunTimeFailure err -> + return $ RunTimeFailure err + +compileProgram :: (MonadIO m, MonadError [T.Text] m) => + [String] -> FilePath -> String -> FilePath + -> m (SBS.ByteString, SBS.ByteString) +compileProgram extra_options futhark backend program = do + (futcode, stdout, stderr) <- liftIO $ readProcessWithExitCode futhark (backend:options) "" + case futcode of + ExitFailure 127 -> throwError [progNotFound $ T.pack futhark] + ExitFailure _ -> throwError [T.decodeUtf8 stderr] + ExitSuccess -> return () + return (stdout, stderr) + where binOutputf = dropExtension program + options = [program, "-o", binOutputf] ++ extra_options + progNotFound s = s <> ": command not found" + +runProgram :: MonadIO m => + String -> [String] + -> String -> T.Text -> Values + -> m (ExitCode, SBS.ByteString, SBS.ByteString) +runProgram runner extra_options prog entry input = do + let progbin = dropExtension prog + dir = takeDirectory prog + binpath = "." progbin + entry_options = ["-e", T.unpack entry] + + (to_run, to_run_args) + | null runner = (binpath, entry_options ++ extra_options) + | otherwise = (runner, binpath : entry_options ++ extra_options) + + input' <- getValuesBS dir input + liftIO $ readProcessWithExitCode to_run to_run_args $ BS.toStrict input' + +-- | Ensure that any reference output files exist, or create them (by +-- compiling the program with the reference compiler and running it on +-- the input) if necessary. +ensureReferenceOutput :: (MonadIO m, MonadError [T.Text] m) => + FilePath -> String -> FilePath -> [InputOutputs] + -> m () +ensureReferenceOutput futhark compiler prog ios = do + missing <- filterM isReferenceMissing $ concatMap entryAndRuns ios + unless (null missing) $ do + void $ compileProgram [] futhark compiler prog + liftIO $ void $ flip pmapIO missing $ \(entry, tr) -> do + (code, stdout, stderr) <- runProgram "" ["-b"] prog entry $ runInput tr + case code of + ExitFailure e -> + fail $ "Reference dataset generation failed with exit code " ++ + show e ++ " and stderr:\n" ++ + map (chr . fromIntegral) (SBS.unpack stderr) + ExitSuccess -> + SBS.writeFile (file (entry, tr)) stdout + where file (entry, tr) = + takeDirectory prog testRunReferenceOutput prog entry tr + + entryAndRuns (InputOutputs entry rts) = map (entry,) rts + + isReferenceMissing (entry, tr) + | Succeeds (Just SuccessGenerateValues) <- runExpectedResult tr = + liftIO . fmap not . doesFileExist . file $ (entry, tr) + | otherwise = + return False diff --git a/src/Futhark/Test/Values.hs b/src/Futhark/Test/Values.hs --- a/src/Futhark/Test/Values.hs +++ b/src/Futhark/Test/Values.hs @@ -17,8 +17,8 @@ -- * Comparing Values , compareValues + , compareValues1 , Mismatch - , explainMismatch ) where @@ -29,7 +29,6 @@ import Data.Binary.Get import Data.Binary.IEEE754 import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Maybe import Data.Int (Int8, Int16, Int32, Int64) import Data.Char (isSpace, ord, chr) import Data.Vector.Binary @@ -46,6 +45,7 @@ import Futhark.Representation.AST.Attributes.Constants (IsValue(..)) import Futhark.Representation.AST.Pretty () import Futhark.Util.Pretty +import Futhark.Util (maybeHead) type STVector s = UMVec.STVector s type Vector = UVec.Vector @@ -452,7 +452,8 @@ -- Comparisons --- | Two values differ in some way. +-- | Two values differ in some way. The 'Show' instance produces a +-- human-readable explanation. data Mismatch = PrimValueMismatch (Int,Int) PrimValue PrimValue -- ^ The position the value number and a flat index -- into the array. @@ -477,17 +478,18 @@ -- | Compare two sets of Futhark values for equality. Shapes and -- types must also match. -compareValues :: [Value] -> [Value] -> Maybe [Mismatch] +compareValues :: [Value] -> [Value] -> [Mismatch] compareValues got expected - | n /= m = Just [ValueCountMismatch n m] - | otherwise = case catMaybes $ zipWith3 compareValue [0..] got expected of - [] -> Nothing - es -> Just es + | n /= m = [ValueCountMismatch n m] + | otherwise = concat $ zipWith3 compareValue [0..] got expected where n = length got m = length expected +-- | As 'compareValues', but only reports one mismatch. +compareValues1 :: [Value] -> [Value] -> Maybe Mismatch +compareValues1 got expected = maybeHead $ compareValues got expected -compareValue :: Int -> Value -> Value -> Maybe Mismatch +compareValue :: Int -> Value -> Value -> [Mismatch] compareValue i got_v expected_v | valueShape got_v == valueShape expected_v = case (got_v, expected_v) of @@ -514,29 +516,29 @@ (BoolValue _ got_vs, BoolValue _ expected_vs) -> compareGen compareBool got_vs expected_vs _ -> - Just $ TypeMismatch i (pretty $ valueElemType got_v) (pretty $ valueElemType expected_v) + [TypeMismatch i (pretty $ valueElemType got_v) (pretty $ valueElemType expected_v)] | otherwise = - Just $ ArrayShapeMismatch i (valueShape got_v) (valueShape expected_v) + [ArrayShapeMismatch i (valueShape got_v) (valueShape expected_v)] where compareNum tol = compareGen $ compareElement tol compareFloat tol = compareGen $ compareFloatElement tol compareGen cmp got expected = - foldl mplus Nothing $ + concat $ zipWith cmp (UVec.toList $ UVec.indexed got) (UVec.toList expected) compareElement tol (j, got) expected - | comparePrimValue tol got expected = Nothing - | otherwise = Just $ PrimValueMismatch (i,j) (value got) (value expected) + | comparePrimValue tol got expected = [] + | otherwise = [PrimValueMismatch (i,j) (value got) (value expected)] compareFloatElement tol (j, got) expected - | isNaN got, isNaN expected = Nothing + | isNaN got, isNaN expected = [] | isInfinite got, isInfinite expected, - signum got == signum expected = Nothing + signum got == signum expected = [] | otherwise = compareElement tol (j, got) expected compareBool (j, got) expected - | got == expected = Nothing - | otherwise = Just $ PrimValueMismatch (i,j) (value got) (value expected) + | got == expected = [] + | otherwise = [PrimValueMismatch (i,j) (value got) (value expected)] comparePrimValue :: (Ord num, Num num) => num -> num -> num -> Bool diff --git a/src/Futhark/Tools.hs b/src/Futhark/Tools.hs --- a/src/Futhark/Tools.hs +++ b/src/Futhark/Tools.hs @@ -20,7 +20,6 @@ where import Control.Monad.Identity -import Data.Semigroup ((<>)) import Futhark.Representation.AST import Futhark.Representation.SOACS.SOAC 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 @@ -23,7 +23,6 @@ import Control.Monad.Except import Control.Monad.State -import Data.Semigroup ((<>)) import qualified Data.Map.Strict as M import qualified Data.Set as S diff --git a/src/Futhark/Transform/Rename.hs b/src/Futhark/Transform/Rename.hs --- a/src/Futhark/Transform/Rename.hs +++ b/src/Futhark/Transform/Rename.hs @@ -38,7 +38,6 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe -import Data.Semigroup ((<>)) import Futhark.Representation.AST.Syntax import Futhark.Representation.AST.Traversals diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs --- a/src/Futhark/TypeCheck.hs +++ b/src/Futhark/TypeCheck.hs @@ -60,7 +60,6 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe -import qualified Data.Semigroup as Sem import Futhark.Analysis.PrimExp import Futhark.Construct (instantiateShapes) @@ -225,7 +224,7 @@ | Consumption Occurences deriving (Show) -instance Sem.Semigroup Consumption where +instance Semigroup Consumption where ConsumptionError e <> _ = ConsumptionError e _ <> ConsumptionError e = ConsumptionError e Consumption o1 <> Consumption o2 @@ -238,7 +237,6 @@ instance Monoid Consumption where mempty = Consumption mempty - mappend = (Sem.<>) -- | The environment contains a variable table and a function table. -- Type checking happens with access to this environment. The @@ -312,9 +310,12 @@ unless (primType $ typeOf attr) $ occur [observation $ S.insert name $ aliases attr] --- | Proclaim that we have written to the given variable. -consume :: Names -> TypeM lore () -consume als = occur [consumption als] +-- | Proclaim that we have written to the given variables. +consume :: Checkable lore => Names -> TypeM lore () +consume als = do + scope <- askScope + let isArray = maybe False ((>0) . arrayRank . typeOf) . (`M.lookup` scope) + occur [consumption $ S.filter isArray als] collectOccurences :: TypeM lore a -> TypeM lore (a, Occurences) collectOccurences m = pass $ do @@ -547,7 +548,9 @@ binding (M.fromList params) $ consumeOnlyParams consumable $ do check - checkReturnAlias $ bodyAliases body + scope <- askScope + let isArray = maybe False ((>0) . arrayRank . typeOf) . (`M.lookup` scope) + checkReturnAlias $ map (S.filter isArray) $ bodyAliases body where param_names = map fst params checkNoDuplicateParams = foldM_ expand [] param_names diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -29,12 +29,15 @@ fromPOSIX, toPOSIX, trim, + pmapIO, zEncodeString ) where import Numeric +import Control.Concurrent import Control.Exception +import Control.Monad import Data.Char import Data.List import Data.Either @@ -186,6 +189,23 @@ -- efficient implementation! trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +fork :: (a -> IO b) -> a -> IO (MVar b) +fork f x = do cell <- newEmptyMVar + void $ forkIO $ do result <- f x + putMVar cell result + return cell + +pmapIO :: (a -> IO b) -> [a] -> IO [b] +pmapIO f elems = go elems [] + where + go [] res = return res + go xs res = do + numThreads <- getNumCapabilities + let (e,es) = splitAt numThreads xs + mvars <- mapM (fork f) e + result <- mapM takeMVar mvars + go es (result ++ res) -- Z-encoding from https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/SymbolNames -- diff --git a/src/Futhark/Util/Log.hs b/src/Futhark/Util/Log.hs --- a/src/Futhark/Util/Log.hs +++ b/src/Futhark/Util/Log.hs @@ -18,15 +18,13 @@ import qualified Control.Monad.RWS.Lazy import qualified Data.Text as T import qualified Data.DList as DL -import qualified Data.Semigroup as Sem newtype Log = Log { unLog :: DL.DList T.Text } -instance Sem.Semigroup Log where +instance Semigroup Log where Log l1 <> Log l2 = Log $ l1 <> l2 instance Monoid Log where - mappend = (Sem.<>) mempty = Log mempty -- | Transform a log into text. Every log entry becomes its own line diff --git a/src/Futhark/Util/Options.hs b/src/Futhark/Util/Options.hs --- a/src/Futhark/Util/Options.hs +++ b/src/Futhark/Util/Options.hs @@ -5,7 +5,6 @@ , commonOptions ) where -import System.Environment import Control.Monad.IO.Class import System.IO import System.Exit @@ -23,9 +22,10 @@ -> [FunOptDescr cfg] -> String -> ([String] -> cfg -> Maybe (IO ())) + -> String + -> [String] -> IO () -mainWithOptions emptyConfig commandLineOptions usage f = do - args <- getArgs +mainWithOptions emptyConfig commandLineOptions usage f prog args = case getOpt' Permute commandLineOptions' args of (opts, nonopts, [], []) -> case applyOpts opts of @@ -37,16 +37,14 @@ where applyOpts opts = do fs <- sequence opts return $ foldl (.) id (reverse fs) emptyConfig - invalid nonopts unrecs errs = do help <- helpStr usage commandLineOptions' + invalid nonopts unrecs errs = do help <- helpStr prog usage commandLineOptions' badOptions help nonopts errs unrecs commandLineOptions' = - commonOptions usage commandLineOptions ++ commandLineOptions - -helpStr :: String -> [OptDescr a] -> IO String -helpStr usage opts = do - prog <- getProgName + commonOptions prog usage commandLineOptions ++ commandLineOptions +helpStr :: String -> String -> [OptDescr a] -> IO String +helpStr prog usage opts = do let header = unlines ["Usage: " ++ prog ++ " " ++ usage, "Options:"] return $ usageInfo header opts @@ -63,8 +61,8 @@ -- | Common definitions for @-v@ and @-h@, given the list of all other -- options. -commonOptions :: String -> [FunOptDescr cfg] -> [FunOptDescr cfg] -commonOptions usage options = +commonOptions :: String -> String -> [FunOptDescr cfg] -> [FunOptDescr cfg] +commonOptions prog usage options = [ Option "V" ["version"] (NoArg $ Left $ do header exitSuccess) @@ -73,7 +71,7 @@ , Option "h" ["help"] (NoArg $ Left $ do header putStrLn "" - putStrLn =<< helpStr usage (commonOptions usage [] ++ options) + putStrLn =<< helpStr prog usage (commonOptions prog usage [] ++ options) exitSuccess) "Print help and exit." ] diff --git a/src/Language/Futhark.hs b/src/Language/Futhark.hs --- a/src/Language/Futhark.hs +++ b/src/Language/Futhark.hs @@ -62,15 +62,14 @@ -- | An Futhark program with type information. type Prog = ProgBase Info VName --- | A known type arg with shape annotations but no aliasing information. -type StructTypeArg = TypeArg (DimDecl VName) () +-- | A known type arg with shape annotations. +type StructTypeArg = TypeArg (DimDecl VName) -- | A type-checked type parameter. type TypeParam = TypeParamBase VName --- | A known array element type with no shape annotations, but aliasing --- information. -type ArrayElemType = ArrayElemTypeBase () Names +-- | A known array element type with no shape annotations. +type ArrayElemType = ArrayElemTypeBase () -- | A type-checked case (of a match expression). type Case = CaseBase Info VName 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 @@ -38,7 +38,6 @@ -- * Queries on types , uniqueness , unique - , recordArrayElemUniqueness , aliases , diet , arrayRank @@ -68,7 +67,6 @@ , removeShapeAnnotations , vacuousShapeAnnotations , typeToRecordArrayElem - , typeToRecordArrayElem' , recordArrayElemToType , tupleRecord , isTupleRecord @@ -126,14 +124,14 @@ -- | Return the shape of a type - for non-arrays, this is 'mempty'. arrayShape :: TypeBase dim as -> ShapeDecl dim -arrayShape (Array _ ds _) = ds +arrayShape (Array _ _ _ ds) = ds arrayShape _ = mempty -- | Return any shape declarations in the type, with duplicates -- removed. nestedDims :: TypeBase (DimDecl VName) as -> [DimDecl VName] nestedDims t = - case t of Array a ds _ -> nub $ arrayNestedDims a <> shapeDims ds + case t of Array _ _ a ds -> nub $ arrayNestedDims a <> shapeDims ds Record fs -> nub $ fold $ fmap nestedDims fs Prim{} -> mempty TypeVar _ _ _ targs -> concatMap typeArgDims targs @@ -141,13 +139,13 @@ Enum{} -> [] where arrayNestedDims ArrayPrimElem{} = mempty - arrayNestedDims (ArrayPolyElem _ targs _) = + arrayNestedDims (ArrayPolyElem _ targs) = concatMap typeArgDims targs arrayNestedDims (ArrayRecordElem ts) = fold (fmap recordArrayElemNestedDims ts) arrayNestedDims ArrayEnumElem{} = mempty - recordArrayElemNestedDims (RecordArrayArrayElem a ds _) = + recordArrayElemNestedDims (RecordArrayArrayElem a ds) = arrayNestedDims a <> shapeDims ds recordArrayElemNestedDims (RecordArrayElem et) = arrayNestedDims et @@ -161,7 +159,7 @@ -- | Set the dimensions of an array. If the given type is not an -- array, return the type unchanged. setArrayShape :: TypeBase dim as -> ShapeDecl dim -> TypeBase dim as -setArrayShape (Array t _ u) ds = Array t ds u +setArrayShape (Array a u t _) ds = Array a u t ds setArrayShape t _ = t -- | Change the shape of a type to be just the 'Rank'. @@ -180,14 +178,10 @@ -- | Return the uniqueness of a type. uniqueness :: TypeBase shape as -> Uniqueness -uniqueness (Array _ _ u) = u +uniqueness (Array _ u _ _) = u uniqueness (TypeVar _ u _ _) = u uniqueness _ = Nonunique -recordArrayElemUniqueness :: RecordArrayElemTypeBase shape as -> Uniqueness -recordArrayElemUniqueness RecordArrayElem{} = Nonunique -recordArrayElemUniqueness (RecordArrayArrayElem _ _ u) = u - -- | @unique t@ is 'True' if the type of the argument is unique. unique :: TypeBase shape as -> Bool unique = (==Unique) . uniqueness @@ -200,13 +194,13 @@ -- | @diet t@ returns a description of how a function parameter of -- type @t@ might consume its argument. diet :: TypeBase shape as -> Diet -diet (Record ets) = RecordDiet $ fmap diet ets -diet (Prim _) = Observe -diet TypeVar{} = Observe -diet (Arrow _ _ t1 t2) = FuncDiet (diet t1) (diet t2) -diet (Array _ _ Unique) = Consume -diet (Array _ _ Nonunique) = Observe -diet (Enum _) = Observe +diet (Record ets) = RecordDiet $ fmap diet ets +diet (Prim _) = Observe +diet TypeVar{} = Observe +diet (Arrow _ _ t1 t2) = FuncDiet (diet t1) (diet t2) +diet (Array _ Unique _ _) = Consume +diet (Array _ Nonunique _ _) = Observe +diet (Enum _) = Observe -- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from -- the parts of @t@ that are denoted as 'Consumed' by the 'Diet' @d@. @@ -234,7 +228,7 @@ -- | Replace no aliasing with an empty alias set. fromStruct :: TypeBase dim as - -> TypeBase dim Names + -> TypeBase dim Aliasing fromStruct t = t `setAliases` S.empty -- | @peelArray n t@ returns the type resulting from peeling the first @@ -242,26 +236,26 @@ -- than @n@ dimensions. peelArray :: Int -> TypeBase dim as -> Maybe (TypeBase dim as) peelArray 0 t = Just t -peelArray n (Array (ArrayPrimElem et _) shape _) +peelArray n (Array _ _ (ArrayPrimElem et) shape) | shapeRank shape == n = Just $ Prim et -peelArray n (Array (ArrayPolyElem et targs als) shape u) +peelArray n (Array als u (ArrayPolyElem et targs) shape) | shapeRank shape == n = Just $ TypeVar als u et targs -peelArray n (Array (ArrayRecordElem ts) shape u) +peelArray n (Array als u (ArrayRecordElem ts) shape) | shapeRank shape == n = Just $ Record $ fmap asType ts - where asType (RecordArrayElem (ArrayPrimElem bt _)) = Prim bt - asType (RecordArrayElem (ArrayPolyElem bt targs als)) = TypeVar als u bt targs + where asType (RecordArrayElem (ArrayPrimElem bt)) = Prim bt + asType (RecordArrayElem (ArrayPolyElem bt targs)) = TypeVar als u bt targs asType (RecordArrayElem (ArrayRecordElem ts')) = Record $ fmap asType ts' - asType (RecordArrayElem (ArrayEnumElem cs _)) = Enum cs - asType (RecordArrayArrayElem et e_shape _) = Array et e_shape u -peelArray n (Array (ArrayEnumElem cs _) shape _) + asType (RecordArrayElem (ArrayEnumElem cs)) = Enum cs + asType (RecordArrayArrayElem et e_shape) = Array als u et e_shape +peelArray n (Array _ _ (ArrayEnumElem cs) shape) | shapeRank shape == n = Just $ Enum cs -peelArray n (Array et shape u) = do +peelArray n (Array als u et shape) = do shape' <- stripDims n shape - return $ Array et shape' u + return $ Array als u et shape' peelArray _ _ = Nothing -- | Remove names from a type - this involves removing all size @@ -290,62 +284,56 @@ -> ShapeDecl dim -> Uniqueness -> Maybe (TypeBase dim as) -arrayOfWithAliases (Array et shape1 _) as shape2 u = - Just $ Array et (shape2 <> shape1) u `setAliases` as +arrayOfWithAliases (Array as1 _ et shape1) as2 shape2 u = + Just $ Array (as1<>as2) u et (shape2 <> shape1) arrayOfWithAliases (Prim et) as shape u = - Just $ Array (ArrayPrimElem et as) shape u + Just $ Array as u (ArrayPrimElem et) shape arrayOfWithAliases (TypeVar _ _ x targs) as shape u = - Just $ Array (ArrayPolyElem x targs as) shape u + Just $ Array as u (ArrayPolyElem x targs) shape arrayOfWithAliases (Record ts) as shape u = do - ts' <- traverse (typeToRecordArrayElem' as) ts - return $ Array (ArrayRecordElem ts') shape u + ts' <- traverse typeToRecordArrayElem ts + return $ Array as u (ArrayRecordElem ts') shape arrayOfWithAliases Arrow{} _ _ _ = Nothing arrayOfWithAliases (Enum cs) as shape u = - Just $ Array (ArrayEnumElem cs as) shape u + Just $ Array as u (ArrayEnumElem cs) shape typeToRecordArrayElem :: Monoid as => - TypeBase dim as - -> Maybe (RecordArrayElemTypeBase dim as) -typeToRecordArrayElem = typeToRecordArrayElem' mempty - -typeToRecordArrayElem' :: Monoid as => - as -> TypeBase dim as - -> Maybe (RecordArrayElemTypeBase dim as) -typeToRecordArrayElem' as (Prim bt) = - Just $ RecordArrayElem $ ArrayPrimElem bt as -typeToRecordArrayElem' as (TypeVar t_as _ bt targs) = - Just $ RecordArrayElem $ ArrayPolyElem bt targs (as <> t_as) -typeToRecordArrayElem' as (Record ts') = + TypeBase dim as -> Maybe (RecordArrayElemTypeBase dim) +typeToRecordArrayElem (Prim bt) = + Just $ RecordArrayElem $ ArrayPrimElem bt +typeToRecordArrayElem (TypeVar _ _ bt targs) = + Just $ RecordArrayElem $ ArrayPolyElem bt targs +typeToRecordArrayElem (Record ts') = RecordArrayElem . ArrayRecordElem <$> - traverse (typeToRecordArrayElem' as) ts' -typeToRecordArrayElem' _ (Array et shape u) = - Just $ RecordArrayArrayElem et shape u -typeToRecordArrayElem' _ Arrow{} = Nothing -typeToRecordArrayElem' as (Enum cs) = - Just $ RecordArrayElem $ ArrayEnumElem cs as + traverse typeToRecordArrayElem ts' +typeToRecordArrayElem (Array _ _ et shape) = + Just $ RecordArrayArrayElem et shape +typeToRecordArrayElem Arrow{} = Nothing +typeToRecordArrayElem (Enum cs) = + Just $ RecordArrayElem $ ArrayEnumElem cs recordArrayElemToType :: Monoid as => - RecordArrayElemTypeBase dim as - -> (TypeBase dim as, as) + RecordArrayElemTypeBase dim + -> TypeBase dim as recordArrayElemToType (RecordArrayElem et) = arrayElemToType et -recordArrayElemToType (RecordArrayArrayElem et shape u) = (Array et shape u, mempty) +recordArrayElemToType (RecordArrayArrayElem et shape) = Array mempty Nonunique et shape -arrayElemToType :: Monoid as => ArrayElemTypeBase dim as -> (TypeBase dim as, as) -arrayElemToType (ArrayPrimElem bt als) = (Prim bt, als) -arrayElemToType (ArrayPolyElem bt targs als) = (TypeVar als Nonunique bt targs, als) +arrayElemToType :: Monoid as => ArrayElemTypeBase dim -> TypeBase dim as +arrayElemToType (ArrayPolyElem bt targs) = + TypeVar mempty Nonunique bt targs arrayElemToType (ArrayRecordElem ts) = - let ts' = fmap recordArrayElemToType ts - in (Record $ fmap fst ts', foldMap snd ts') -arrayElemToType (ArrayEnumElem cs als) = (Enum cs, als) + Record $ fmap recordArrayElemToType ts +arrayElemToType (ArrayPrimElem bt) = Prim bt +arrayElemToType (ArrayEnumElem cs) = Enum cs -- | @stripArray n t@ removes the @n@ outermost layers of the array. -- Essentially, it is the type of indexing an array of type @t@ with -- @n@ indexes. stripArray :: Monoid as => Int -> TypeBase dim as -> TypeBase dim as -stripArray n (Array et shape u) +stripArray n (Array als u et shape) | Just shape' <- stripDims n shape = - Array et shape' u - | otherwise = fst (arrayElemToType et) `setUniqueness` u + Array als u et shape' + | otherwise = arrayElemToType et `setUniqueness` u `addAliases` (<>als) stripArray _ t = t -- | Create a record type corresponding to a tuple with the given @@ -386,28 +374,14 @@ -- | Set the uniqueness attribute of a type. If the type is a tuple, -- the uniqueness of its components will be modified. setUniqueness :: TypeBase dim as -> Uniqueness -> TypeBase dim as -setUniqueness (Array et shape _) u = - Array (setArrayElemUniqueness et u) shape u +setUniqueness (Array als _ et shape) u = + Array als u et shape setUniqueness (TypeVar als _ t targs) u = TypeVar als u t targs setUniqueness (Record ets) u = Record $ fmap (`setUniqueness` u) ets setUniqueness t _ = t -setArrayElemUniqueness :: ArrayElemTypeBase dim as - -> Uniqueness -> ArrayElemTypeBase dim as -setArrayElemUniqueness (ArrayPrimElem bt as) _ = - ArrayPrimElem bt as -setArrayElemUniqueness (ArrayPolyElem v args as) _ = - ArrayPolyElem v args as -setArrayElemUniqueness (ArrayRecordElem r) u = - ArrayRecordElem $ fmap set r - where set (RecordArrayElem et) = - RecordArrayElem $ setArrayElemUniqueness et u - set (RecordArrayArrayElem et shape e_u) = - RecordArrayArrayElem (setArrayElemUniqueness et u) shape e_u -setArrayElemUniqueness (ArrayEnumElem cs as) _ = ArrayEnumElem cs as - -- | @t \`setAliases\` als@ returns @t@, but with @als@ substituted for -- any already present aliasing. setAliases :: TypeBase dim asf -> ast -> TypeBase dim ast @@ -445,6 +419,11 @@ rank :: Int -> ShapeDecl () rank n = ShapeDecl $ replicate n () +unscopeAliases :: S.Set VName -> CompType -> CompType +unscopeAliases bound_here t = t `addAliases` S.map unbind + where unbind (AliasBound v) | v `S.member` bound_here = AliasFree v + unbind a = a + -- | 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 -> CompType @@ -459,19 +438,21 @@ Record $ M.unions $ reverse $ map record fs where record (RecordFieldExplicit name e _) = M.singleton name $ typeOf e record (RecordFieldImplicit name (Info t) _) = - M.singleton (baseName name) $ t `addAliases` S.insert name + M.singleton (baseName name) $ t `addAliases` S.insert (AliasBound name) typeOf (ArrayLit _ (Info t) _) = t typeOf (Range _ _ _ (Info t) _) = t typeOf (BinOp _ _ _ _ (Info t) _) = removeShapeAnnotations t typeOf (Project _ _ (Info t) _) = t typeOf (If _ _ _ (Info t) _) = t -typeOf (Var qn (Info t) _) = removeShapeAnnotations t `addAliases` S.insert (qualLeaf qn) +typeOf (Var _ (Info t) _) = removeShapeAnnotations t typeOf (Ascript e _ _) = typeOf e typeOf (Apply _ _ _ (Info t) _) = removeShapeAnnotations t typeOf (Negate e _) = typeOf e -typeOf (LetPat _ _ _ body _) = typeOf body +typeOf (LetPat _ pat _ body _) = + unscopeAliases (S.map identName $ patIdentSet pat) $ typeOf body typeOf (LetFun _ _ body _) = typeOf body -typeOf (LetWith _ _ _ _ body _) = typeOf body +typeOf (LetWith dest _ _ _ body _) = + unscopeAliases (S.singleton $ identName dest) $ typeOf body typeOf (Index _ _ (Info t) _) = t typeOf (Update e _ _ _) = typeOf e `setAliases` mempty typeOf (RecordUpdate _ _ _ (Info t) _) = removeShapeAnnotations t @@ -489,15 +470,18 @@ typeOf (Filter _ arr _) = typeOf arr `setAliases` mempty `setUniqueness` Unique typeOf (Partition _ _ arr _) = tupleRecord [typeOf arr `setAliases` mempty `setUniqueness` Unique, - Array (ArrayPrimElem (Signed Int32) mempty) (rank 1) Unique] + Array mempty Unique (ArrayPrimElem (Signed Int32)) (rank 1)] typeOf (Stream _ lam _ _) = rettype (typeOf lam) `setUniqueness` Unique where rettype (Arrow _ _ _ t) = rettype t rettype t = t typeOf (DoLoop _ pat _ _ _ _) = patternType pat -typeOf (Lambda _ params _ _ (Info (als, t)) _) = +typeOf (Lambda tparams params _ _ (Info (als, t)) _) = + unscopeAliases bound_here $ removeShapeAnnotations (foldr (uncurry (Arrow ()) . patternParam) t params) `setAliases` als + where bound_here = S.fromList (map typeParamName tparams) <> + S.map identName (mconcat $ map patIdentSet params) typeOf (OpSection _ (Info t) _) = removeShapeAnnotations t typeOf (OpSectionLeft _ _ _ (_, Info pt2) (Info ret) _) = @@ -522,7 +506,7 @@ unfoldFunType t = ([], t) -- | The type names mentioned in a type. -typeVars :: Monoid as => TypeBase dim as -> Names +typeVars :: Monoid as => TypeBase dim as -> S.Set VName typeVars t = case t of Prim{} -> mempty @@ -530,12 +514,15 @@ mconcat $ typeVarFree tn : map typeArgFree targs Arrow _ _ t1 t2 -> typeVars t1 <> typeVars t2 Record fields -> foldMap typeVars fields - Array ArrayPrimElem{} _ _ -> mempty - Array (ArrayPolyElem tn targs _) _ _ -> + Array _ _ ArrayPrimElem{} _ -> mempty + Array _ _ (ArrayPolyElem tn targs) _ -> mconcat $ typeVarFree tn : map typeArgFree targs - Array (ArrayRecordElem fields) _ _ -> - foldMap (typeVars . fst . recordArrayElemToType) fields - Array ArrayEnumElem{} _ _ -> mempty + Array _ _ (ArrayRecordElem fields) _ -> + foldMap (typeVars . f) fields + -- This local function is to avoid an ambiguous type. + where f :: RecordArrayElemTypeBase dim -> TypeBase dim () + f = recordArrayElemToType + Array _ _ ArrayEnumElem{} _ -> mempty Enum{} -> mempty where typeVarFree = S.singleton . typeLeaf typeArgFree (TypeArgType ta _) = typeVars ta @@ -544,59 +531,28 @@ -- | The result of applying the arguments of the given types to a -- function with the given return type, consuming its parameters with -- the given diets. -returnType :: TypeBase dim () - -> [Diet] - -> [CompType] - -> TypeBase dim Names -returnType (Array et shape Unique) _ _ = - Array (bimap id (const mempty) et) shape Unique -returnType (Array et shape Nonunique) ds args = - Array (arrayElemReturnType et ds args) shape Nonunique -returnType (Record fs) ds args = - Record $ fmap (\et -> returnType et ds args) fs +returnType :: TypeBase dim Aliasing + -> Diet + -> CompType + -> TypeBase dim Aliasing +returnType (Array _ Unique et shape) _ _ = + Array mempty Unique et shape +returnType (Array als Nonunique et shape) d arg = + Array (als<>arg_als) Unique et shape -- Intentional! + where arg_als = aliases $ maskAliases arg d +returnType (Record fs) d arg = + Record $ fmap (\et -> returnType et d arg) fs returnType (Prim t) _ _ = Prim t -returnType (TypeVar () Unique t targs) _ _ = - TypeVar mempty Unique t $ map (bimap id (const mempty)) targs -returnType (TypeVar () Nonunique t targs) ds args = - TypeVar als Nonunique t $ map (\arg -> typeArgReturnType arg ds args) targs - where als = mconcat $ map aliases $ zipWith maskAliases args ds -returnType (Arrow _ v t1 t2) ds args = - Arrow als v (bimap id (const mempty) t1) (returnType t2 ds args) - where als = foldMap aliases $ zipWith maskAliases args ds +returnType (TypeVar _ Unique t targs) _ _ = + TypeVar mempty Unique t targs +returnType (TypeVar als Nonunique t targs) d arg = + TypeVar (als<>arg_als) Unique t targs -- Intentional! + where arg_als = aliases $ maskAliases arg d +returnType (Arrow _ v t1 t2) d arg = + Arrow als v (bimap id (const mempty) t1) (t2 `setAliases` als) + where als = aliases $ maskAliases arg d returnType (Enum cs) _ _ = Enum cs -typeArgReturnType :: TypeArg shape () -> [Diet] -> [CompType] - -> TypeArg shape Names -typeArgReturnType (TypeArgDim v loc) _ _ = - TypeArgDim v loc -typeArgReturnType (TypeArgType t loc) ds args = - TypeArgType (returnType t ds args) loc - -arrayElemReturnType :: ArrayElemTypeBase dim () - -> [Diet] - -> [CompType] - -> ArrayElemTypeBase dim Names -arrayElemReturnType (ArrayPrimElem bt ()) ds args = - ArrayPrimElem bt als - where als = mconcat $ map aliases $ zipWith maskAliases args ds -arrayElemReturnType (ArrayPolyElem bt targs ()) ds args = - ArrayPolyElem bt (map (\arg -> typeArgReturnType arg ds args) targs) als - where als = mconcat $ map aliases $ zipWith maskAliases args ds -arrayElemReturnType (ArrayRecordElem et) ds args = - ArrayRecordElem $ fmap (\t -> recordArrayElemReturnType t ds args) et -arrayElemReturnType (ArrayEnumElem cs ()) ds args = - ArrayEnumElem cs als - where als = mconcat $ map aliases $ zipWith maskAliases args ds - -recordArrayElemReturnType :: RecordArrayElemTypeBase dim () - -> [Diet] - -> [CompType] - -> RecordArrayElemTypeBase dim Names -recordArrayElemReturnType (RecordArrayElem et) ds args = - RecordArrayElem $ arrayElemReturnType et ds args -recordArrayElemReturnType (RecordArrayArrayElem et shape u) ds args = - RecordArrayArrayElem (arrayElemReturnType et ds args) shape u - -- | Is the type concrete, i.e, without any type variables or function arrows? concreteType :: TypeBase f vn -> Bool concreteType Prim{} = True @@ -604,14 +560,14 @@ concreteType Arrow{} = False concreteType (Record ts) = all concreteType ts concreteType Enum{} = True -concreteType (Array at _ _) = concreteArrayType at +concreteType (Array _ _ at _) = concreteArrayType at where concreteArrayType ArrayPrimElem{} = True concreteArrayType ArrayPolyElem{} = False concreteArrayType (ArrayRecordElem ts) = all concreteRecordArrayElem ts concreteArrayType ArrayEnumElem{} = True concreteRecordArrayElem (RecordArrayElem et) = concreteArrayType et - concreteRecordArrayElem (RecordArrayArrayElem et _ _) = concreteArrayType et + concreteRecordArrayElem (RecordArrayArrayElem et _) = concreteArrayType et -- | @orderZero t@ is 'True' if the argument type has order 0, i.e., it is not -- a function type, does not contain a function type as a subcomponent, and may @@ -625,7 +581,7 @@ orderZero Enum{} = True -- | Extract all the shape names that occur in a given pattern. -patternDimNames :: PatternBase Info VName -> Names +patternDimNames :: PatternBase Info VName -> S.Set VName patternDimNames (TuplePattern ps _) = foldMap patternDimNames ps patternDimNames (RecordPattern fs _) = foldMap (patternDimNames . snd) fs patternDimNames (PatternParens p _) = patternDimNames p @@ -636,9 +592,9 @@ patternDimNames (PatternLit _ (Info tp) _) = typeDimNames tp -- | Extract all the shape names that occur in a given type. -typeDimNames :: TypeBase (DimDecl VName) als -> Names +typeDimNames :: TypeBase (DimDecl VName) als -> S.Set VName typeDimNames = foldMap dimName . nestedDims - where dimName :: DimDecl VName -> Names + where dimName :: DimDecl VName -> S.Set VName dimName (NamedDim qn) = S.singleton $ qualLeaf qn dimName _ = mempty @@ -774,13 +730,13 @@ mapMaybe mkIntrinsicBinOp [minBound..maxBound] ++ [("flatten", IntrinsicPolyFun [tp_a] - [Array (ArrayPolyElem tv_a' [] ()) (rank 2) Nonunique] $ - Array (ArrayPolyElem tv_a' [] ()) (rank 1) Nonunique), + [Array () Nonunique (ArrayPolyElem tv_a' []) (rank 2)] $ + Array () Nonunique (ArrayPolyElem tv_a' []) (rank 1)), ("unflatten", IntrinsicPolyFun [tp_a] [Prim $ Signed Int32, Prim $ Signed Int32, - Array (ArrayPolyElem tv_a' [] ()) (rank 1) Nonunique] $ - Array (ArrayPolyElem tv_a' [] ()) (rank 2) Nonunique), + Array () Nonunique (ArrayPolyElem tv_a' []) (rank 1)] $ + Array () Nonunique (ArrayPolyElem tv_a' []) (rank 2)), ("concat", IntrinsicPolyFun [tp_a] [arr_a, arr_a] uarr_a), @@ -790,14 +746,14 @@ ("cmp_threshold", IntrinsicPolyFun [] [Prim $ Signed Int32, - Array (ArrayPrimElem (Signed Int32) ()) (rank 1) Nonunique] $ + Array () Nonunique (ArrayPrimElem (Signed Int32)) (rank 1)] $ Prim Bool), ("scatter", IntrinsicPolyFun [tp_a] - [Array (ArrayPolyElem tv_a' [] ()) (rank 1) Unique, - Array (ArrayPrimElem (Signed Int32) ()) (rank 1) Nonunique, - Array (ArrayPolyElem tv_a' [] ()) (rank 1) Nonunique] $ - Array (ArrayPolyElem tv_a' [] ()) (rank 1) Unique), + [Array () Unique (ArrayPolyElem tv_a' []) (rank 1), + Array () Nonunique (ArrayPrimElem (Signed Int32)) (rank 1), + Array () Nonunique (ArrayPolyElem tv_a' []) (rank 1)] $ + Array () Unique (ArrayPolyElem tv_a' []) (rank 1)), ("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), @@ -806,7 +762,7 @@ [uarr_a, t_a `arr` (t_a `arr` t_a), t_a, - Array (ArrayPrimElem (Signed Int32) ()) (rank 1) Nonunique, + Array () Nonunique (ArrayPrimElem (Signed Int32)) (rank 1), arr_a] uarr_a), @@ -824,7 +780,7 @@ ("partition", IntrinsicPolyFun [tp_a] [Prim (Signed Int32), t_a `arr` Prim (Signed Int32), arr_a] $ - tupleRecord [uarr_a, Array (ArrayPrimElem (Signed Int32) ()) (rank 1) Unique]), + tupleRecord [uarr_a, Array () Unique (ArrayPrimElem (Signed Int32)) (rank 1)]), ("stream_map", IntrinsicPolyFun [tp_a, tp_b] [arr_a `arr` arr_b, arr_a] uarr_b), @@ -845,21 +801,22 @@ where tv_a = VName (nameFromString "a") 0 tv_a' = typeName tv_a t_a = TypeVar () Nonunique tv_a' [] - arr_a = Array (ArrayPolyElem tv_a' [] ()) (rank 1) Nonunique - uarr_a = Array (ArrayPolyElem tv_a' [] ()) (rank 1) Unique + arr_a = Array () Nonunique (ArrayPolyElem tv_a' []) (rank 1) + uarr_a = Array () Unique (ArrayPolyElem tv_a' []) (rank 1) tp_a = TypeParamType Unlifted tv_a noLoc tv_b = VName (nameFromString "b") 1 tv_b' = typeName tv_b t_b = TypeVar () Nonunique tv_b' [] - arr_b = Array (ArrayPolyElem tv_b' [] ()) (rank 1) Nonunique - uarr_b = Array (ArrayPolyElem tv_b' [] ()) (rank 1) Unique + arr_b = Array () Nonunique (ArrayPolyElem tv_b' []) (rank 1) + uarr_b = Array () Unique (ArrayPolyElem tv_b' []) (rank 1) tp_b = TypeParamType Unlifted tv_b noLoc - arr_a_b = Array (ArrayRecordElem (M.fromList $ zip tupleFieldNames - [RecordArrayElem $ ArrayPolyElem tv_a' [] (), - RecordArrayElem $ ArrayPolyElem tv_b' [] ()])) - (rank 1) Nonunique + arr_a_b = Array () Nonunique + (ArrayRecordElem (M.fromList $ zip tupleFieldNames + [RecordArrayElem $ ArrayPolyElem tv_a' [], + RecordArrayElem $ ArrayPolyElem tv_b' []])) + (rank 1) t_arr_a_arr_b = Record $ M.fromList $ zip tupleFieldNames [arr_a, arr_b] arr = Arrow mempty Nothing @@ -1040,7 +997,7 @@ type UncheckedTypeExp = TypeExp Name -- | An array element type with no aliasing information. -type UncheckedArrayElemType = ArrayElemTypeBase (ShapeDecl Name) () +type UncheckedArrayElemType = ArrayElemTypeBase (ShapeDecl Name) -- | A type declaration with no expanded type. type UncheckedTypeDecl = TypeDeclBase NoInfo Name diff --git a/src/Language/Futhark/Core.hs b/src/Language/Futhark/Core.hs --- a/src/Language/Futhark/Core.hs +++ b/src/Language/Futhark/Core.hs @@ -36,7 +36,6 @@ import Data.String import Data.Word (Word8, Word16, Word32, Word64) import Data.Loc -import qualified Data.Semigroup as Sem import qualified Data.Text as T import Futhark.Util.Pretty @@ -48,12 +47,11 @@ | Unique -- ^ No references outside current function. deriving (Eq, Ord, Show) -instance Sem.Semigroup Uniqueness where +instance Semigroup Uniqueness where (<>) = min instance Monoid Uniqueness where mempty = Unique - mappend = (Sem.<>) instance Pretty Uniqueness where ppr Unique = star @@ -69,12 +67,11 @@ | Commutative deriving (Eq, Ord, Show) -instance Sem.Semigroup Commutativity where +instance Semigroup Commutativity where (<>) = min instance Monoid Commutativity where mempty = Commutative - mappend = (Sem.<>) -- | The name of the default program entry point (main). defaultEntryPoint :: Name @@ -84,7 +81,7 @@ -- compiler. 'String's, being lists of characters, are very slow, -- while 'T.Text's are based on byte-arrays. newtype Name = Name T.Text - deriving (Show, Eq, Ord, IsString, Sem.Semigroup) + deriving (Show, Eq, Ord, IsString, Semigroup) instance Pretty Name where ppr = text . nameToString @@ -106,14 +103,21 @@ nameFromText = Name -- | A human-readable location string, of the form --- @filename:lineno:columnno@. +-- @filename:lineno:columnno@. This follows the GNU coding standards +-- for error messages: +-- https://www.gnu.org/prep/standards/html_node/Errors.html +-- +-- This function assumes that both start and end position is in the +-- same file (it is not clear what the alternative would even mean). locStr :: SrcLoc -> String locStr (SrcLoc NoLoc) = "unknown location" -locStr (SrcLoc (Loc (Pos file line1 col1 _) (Pos _ line2 col2 _))) = - -- Assume that both positions are in the same file (what would the - -- alternative mean?) - file ++ ":" ++ show line1 ++ ":" ++ show col1 - ++ "-" ++ show line2 ++ ":" ++ show col2 +locStr (SrcLoc (Loc (Pos file line1 col1 _) (Pos _ line2 col2 _))) + -- Do not show line2 if it is identical to line1. + | line1 == line2 = + first_part ++ "-" ++ show col2 + | otherwise = + first_part ++ "-" ++ show line2 ++ ":" ++ show col2 + where first_part = file ++ ":" ++ show line1 ++ ":" ++ show col1 -- | A name tagged with some integer. Only the integer is used in -- comparisons, no matter the type of @vn@. 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 @@ -27,7 +27,6 @@ import Data.List hiding (break) import Data.Maybe import qualified Data.Map as M -import qualified Data.Semigroup as Sem import Data.Monoid import Data.Loc @@ -78,9 +77,6 @@ stacktrace :: EvalM [SrcLoc] stacktrace = asks $ map stackFrameSrcLoc . reverse . fst -stacktraceTop :: EvalM SrcLoc -stacktraceTop = fromMaybe noLoc . maybeHead <$> stacktrace - lookupImport :: FilePath -> EvalM (Maybe Env) lookupImport f = asks $ M.lookup f . snd @@ -213,9 +209,8 @@ instance Monoid Env where mempty = Env mempty mempty - mappend = (Sem.<>) -instance Sem.Semigroup Env where +instance Semigroup Env where Env vm1 tm1 <> Env vm2 tm2 = Env (vm1 <> vm2) (tm1 <> tm2) newtype InterpreterError = InterpreterError String @@ -240,7 +235,10 @@ trace :: Value -> EvalM () trace v = do - top <- stacktraceTop + -- We take the second-to-last element of the stack, because any + -- actual call to 'implicits.trace' is going to be in the trace + -- function in the prelude, which is not interesting. + top <- fromMaybe noLoc . maybeHead . drop 1 . reverse <$> stacktrace liftF $ ExtOpTrace top (pretty v) () typeEnv :: Env -> T.Env @@ -336,27 +334,22 @@ -> Value -> Either String (M.Map VName (Maybe T.BoundV, Value)) --- Empty arrays always match. -matchValueToType env m t@(Array _ (ShapeDecl ds@(d:_)) _) val@(ValueArray arr) - | any zeroDim ds, emptyShape (valueShape val) = - Right $ m <> mconcat (map namedAreZero ds) - - | otherwise = - case d of - NamedDim v - | Just x <- look v -> - if x == arr_n - then continue m - else wrong $ "`" <> pretty v <> "` (" <> pretty x <> ")" - | otherwise -> - continue $ M.insert (qualLeaf v) - (Just $ T.BoundV [] $ Prim $ Signed Int32, - ValuePrim $ SignedValue $ Int32Value arr_n) - m - AnyDim -> continue m - ConstDim x - | fromIntegral x == arr_n -> continue m - | otherwise -> wrong $ pretty x +matchValueToType env m t@(Array _ _ _ (ShapeDecl ds@(d:_))) val@(ValueArray arr) = + case d of + NamedDim v + | Just x <- look v -> + if x == arr_n + then continue m + else emptyOrWrong $ "`" <> pretty v <> "` (" <> pretty x <> ")" + | otherwise -> + continue $ M.insert (qualLeaf v) + (Just $ T.BoundV [] $ Prim $ Signed Int32, + ValuePrim $ SignedValue $ Int32Value arr_n) + m + AnyDim -> continue m + ConstDim x + | fromIntegral x == arr_n -> continue m + | otherwise -> emptyOrWrong $ pretty x where arr_n = arrayLength arr look v @@ -367,9 +360,19 @@ | otherwise = Nothing continue m' = case elems arr of - [] -> return m' - v:_ -> matchValueToType env m' (stripArray 1 t) v + [] -> + -- We have to ensure that remaining unbound shape + -- parameters become zeroes. + return $ m' <> mconcat (map namedAreZero ds) + v:_ -> + matchValueToType env m' (stripArray 1 t) v + -- Empty arrays always match if nothing else does. + emptyOrWrong x + | any zeroDim ds, emptyShape (valueShape val) = + Right $ m <> mconcat (map namedAreZero ds) + | otherwise = wrong x + wrong x = Left $ "Size annotation " <> x <> " does not match observed size " <> pretty arr_n <> "." @@ -499,7 +502,7 @@ evalType env (Record fs) = Record <$> traverse (evalType env) fs evalType env (Arrow () p t1 t2) = Arrow () p <$> evalType env t1 <*> evalType env t2 -evalType env t@(Array _ shape u) = do +evalType env t@(Array _ u _ shape) = do let et = stripArray (shapeRank shape) t et' <- evalType env et shape' <- traverse evalDim shape @@ -580,8 +583,8 @@ t <- evalType env $ unInfo $ expandedType td case matchValueToType env mempty t v of Right _ -> return v - Left _ -> bad loc env $ "Value `" <> pretty v <> "` cannot match shape of type `" <> - pretty (declaredType td) <> "` (`" <> pretty t <> "`)." + Left err -> bad loc env $ "Value `" <> pretty v <> "` cannot match shape of type `" <> + pretty (declaredType td) <> "` (`" <> pretty t <> "`): " ++ err eval env (LetPat _ p e body _) = do v <- eval env e @@ -692,8 +695,9 @@ where match vt v = case matchValueToType env mempty vt v of Right _ -> return v - Left _ -> bad loc env $ "Value `" <> pretty v <> - "` cannot match type `" <> pretty vt <> "`." + Left err -> + bad loc env $ "Value `" <> pretty v <> + "` cannot match type `" <> pretty vt <> "`: " ++ err eval env (Lambda tparams (p:ps) body mrd (Info (als, ret)) loc) = return $ ValueFun $ \v -> do @@ -772,13 +776,13 @@ eval env (Match e cs _ _) = do v <- eval env e match v cs - where match v [] = + where match _ [] = fail "Pattern match failure." - match v (c:cs) = do + match v (c:cs') = do c' <- evalCase v env c case c' of Just v' -> return v' - Nothing -> match v cs + Nothing -> match v cs' eval _ e = error $ "eval not yet: " ++ show e diff --git a/src/Language/Futhark/Parser.hs b/src/Language/Futhark/Parser.hs --- a/src/Language/Futhark/Parser.hs +++ b/src/Language/Futhark/Parser.hs @@ -2,6 +2,7 @@ module Language.Futhark.Parser ( parseFuthark , parseExp + , parseModExp , parseType , parseValue @@ -35,6 +36,12 @@ parseExp :: FilePath -> T.Text -> Either ParseError UncheckedExp parseExp = parse expression + +-- | Parse a Futhark module expression from the given 'String', using the +-- 'FilePath' as the source name for error messages. +parseModExp :: FilePath -> T.Text + -> Either ParseError (ModExpBase NoInfo Name) +parseModExp = parse modExpression -- | Parse an Futhark type from the given 'String', using the -- 'FilePath' as the source name for error messages. 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 @@ -5,6 +5,7 @@ module Language.Futhark.Parser.Parser ( prog , expression + , modExpression , futharkType , anyValue , anyValues @@ -40,6 +41,7 @@ %name prog Prog %name futharkType TypeExp %name expression Exp +%name modExpression ModExp %name declaration Dec %name anyValue Value %name anyValues CatValues 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 @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- | Futhark prettyprinter. This module defines 'Pretty' instances -- for the AST defined in "Language.Futhark.Syntax". module Language.Futhark.Pretty @@ -107,14 +108,14 @@ instance Pretty (ShapeDecl ()) where ppr (ShapeDecl ds) = mconcat $ replicate (length ds) $ text "[]" -instance Pretty (ShapeDecl dim) => Pretty (RecordArrayElemTypeBase dim as) where +instance Pretty (ShapeDecl dim) => Pretty (RecordArrayElemTypeBase dim) where ppr (RecordArrayElem et) = ppr et - ppr (RecordArrayArrayElem et shape u) = - ppr u <> ppr shape <> ppr et + ppr (RecordArrayArrayElem et shape) = + ppr shape <> ppr et -instance Pretty (ShapeDecl dim) => Pretty (ArrayElemTypeBase dim as) where - ppr (ArrayPrimElem pt _) = ppr pt - ppr (ArrayPolyElem v args _) = +instance Pretty (ShapeDecl dim) => Pretty (ArrayElemTypeBase dim) where + ppr (ArrayPrimElem pt) = ppr pt + ppr (ArrayPolyElem v args) = ppr (qualNameFromTypeName v) <+> spread (map ppr args) ppr (ArrayRecordElem fs) | Just ts <- areTupleFields fs = @@ -122,7 +123,7 @@ | otherwise = braces (commasep $ map ppField $ M.toList fs) where ppField (name, t) = text (nameToString name) <> colon <+> ppr t - ppr (ArrayEnumElem cs _) = + ppr (ArrayEnumElem cs) = cat $ punctuate (text " | ") $ map ((text "#" <>) . ppr) cs instance Pretty (ShapeDecl dim) => Pretty (TypeBase dim as) where @@ -130,7 +131,7 @@ pprPrec _ (Prim et) = ppr et pprPrec _ (TypeVar _ u et targs) = ppr u <> ppr (qualNameFromTypeName et) <+> spread (map ppr targs) - pprPrec _ (Array at shape u) = ppr u <> ppr shape <> ppr at + pprPrec _ (Array _ u at shape) = ppr u <> ppr shape <> ppr at pprPrec _ (Record fs) | Just ts <- areTupleFields fs = parens $ commasep $ map ppr ts @@ -145,7 +146,7 @@ pprPrec _ (Enum cs) = cat $ punctuate (text " | ") $ map ((text "#" <>) . ppr) cs -instance Pretty (ShapeDecl dim) => Pretty (TypeArg dim as) where +instance Pretty (ShapeDecl dim) => Pretty (TypeArg dim) where ppr (TypeArgDim d _) = ppr $ ShapeDecl [d] ppr (TypeArgType t _) = ppr t diff --git a/src/Language/Futhark/Semantic.hs b/src/Language/Futhark/Semantic.hs --- a/src/Language/Futhark/Semantic.hs +++ b/src/Language/Futhark/Semantic.hs @@ -22,15 +22,16 @@ ) where -import Data.Semigroup ((<>)) import Data.Loc import qualified Data.Map.Strict as M -import qualified Data.Semigroup as Sem import qualified System.FilePath.Posix as Posix import qualified System.FilePath as Native +import Prelude hiding (mod) + import Language.Futhark import Futhark.Util (dropLast, toPOSIX, fromPOSIX) +import Futhark.Util.Pretty -- | Canonical reference to a Futhark code file. Does not include the -- @.fut@ extension. This is most often a path relative to the @@ -131,10 +132,36 @@ , envNameMap :: NameMap } deriving (Show) -instance Sem.Semigroup Env where +instance Semigroup Env where Env vt1 tt1 st1 mt1 nt1 <> Env vt2 tt2 st2 mt2 nt2 = Env (vt1<>vt2) (tt1<>tt2) (st1<>st2) (mt1<>mt2) (nt1<>nt2) instance Monoid Env where mempty = Env mempty mempty mempty mempty mempty - mappend = (Sem.<>) + +instance Pretty MTy where + ppr = ppr . mtyMod + +instance Pretty Mod where + ppr (ModEnv e) = ppr e + ppr (ModFun (FunSig _ mod mty)) = ppr mod <+> text "->" ppr mty + +instance Pretty Env where + ppr (Env vtable ttable sigtable modtable _) = + nestedBlock "{" "}" $ stack $ punctuate line $ concat + [map renderTypeBind (M.toList ttable), + map renderValBind (M.toList vtable), + map renderModType (M.toList sigtable), + map renderMod (M.toList modtable)] + where renderTypeBind (name, TypeAbbr l tps tp) = + p l <+> pprName name <> mconcat (map ((text " "<>) . ppr) tps) <> + text " =" <+> ppr tp + where p Lifted = text "type^" + p Unlifted = text "type" + renderValBind (name, BoundV tps t) = + text "val" <+> pprName name <> mconcat (map ((text " "<>) . ppr) tps) <> + text " =" <+> ppr t + renderModType (name, _sig) = + text "module type" <+> pprName name + renderMod (name, mod) = + text "module" <+> pprName name <> text " =" <+> ppr mod 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 @@ -78,7 +78,8 @@ -- * Miscellaneous , NoInfo(..) , Info(..) - , Names + , Alias(..) + , Aliasing , QualName(..) ) where @@ -96,7 +97,6 @@ import Data.Ord import qualified Data.Set as S import Data.Traversable -import qualified Data.Semigroup as Sem import Data.List import Prelude @@ -118,10 +118,10 @@ Show (f Int), Show (f [TypeBase () ()]), Show (f StructType), - Show (f (Names, StructType)), + Show (f (Aliasing, StructType)), Show (f ([TypeBase () ()], PatternType)), Show (f (M.Map VName VName)), - Show (f [RecordArrayElemTypeBase () Names]), + Show (f [RecordArrayElemTypeBase ()]), Show (f Uniqueness), Show (f ([CompType], CompType))) => Showable f vn where @@ -248,12 +248,11 @@ instance Functor ShapeDecl where fmap f (ShapeDecl ds) = ShapeDecl $ map f ds -instance Sem.Semigroup (ShapeDecl dim) where +instance Semigroup (ShapeDecl dim) where ShapeDecl l1 <> ShapeDecl l2 = ShapeDecl $ l1 ++ l2 instance Monoid (ShapeDecl dim) where mempty = ShapeDecl [] - mappend = (Sem.<>) -- | The number of dimensions contained in a shape. shapeRank :: ShapeDecl dim -> Int @@ -293,44 +292,44 @@ qualNameFromTypeName (TypeName qs x) = QualName qs x -- | Types that can be elements of tuple-arrays. -data RecordArrayElemTypeBase dim as = - RecordArrayElem (ArrayElemTypeBase dim as) - | RecordArrayArrayElem (ArrayElemTypeBase dim as) (ShapeDecl dim) Uniqueness +data RecordArrayElemTypeBase dim = + RecordArrayElem (ArrayElemTypeBase dim) + | RecordArrayArrayElem (ArrayElemTypeBase dim) (ShapeDecl dim) deriving (Eq, Show) -instance Bitraversable RecordArrayElemTypeBase where - bitraverse f g (RecordArrayElem t) = RecordArrayElem <$> bitraverse f g t - bitraverse f g (RecordArrayArrayElem a shape u) = - RecordArrayArrayElem <$> bitraverse f g a <*> traverse f shape <*> pure u +instance Traversable RecordArrayElemTypeBase where + traverse f (RecordArrayElem t) = RecordArrayElem <$> traverse f t + traverse f (RecordArrayArrayElem a shape) = + RecordArrayArrayElem <$> traverse f a <*> traverse f shape -instance Bifunctor RecordArrayElemTypeBase where - bimap = bimapDefault +instance Functor RecordArrayElemTypeBase where + fmap = fmapDefault -instance Bifoldable RecordArrayElemTypeBase where - bifoldMap = bifoldMapDefault +instance Foldable RecordArrayElemTypeBase where + foldMap = foldMapDefault -data ArrayElemTypeBase dim as = - ArrayPrimElem PrimType as - | ArrayPolyElem TypeName [TypeArg dim as] as - | ArrayRecordElem (M.Map Name (RecordArrayElemTypeBase dim as)) - | ArrayEnumElem [Name] as +data ArrayElemTypeBase dim = + ArrayPrimElem PrimType + | ArrayPolyElem TypeName [TypeArg dim] + | ArrayRecordElem (M.Map Name (RecordArrayElemTypeBase dim)) + | ArrayEnumElem [Name] deriving (Eq, Show) -instance Bitraversable ArrayElemTypeBase where - bitraverse _ g (ArrayPrimElem t as) = - ArrayPrimElem t <$> g as - bitraverse f g (ArrayPolyElem t args as) = - ArrayPolyElem t <$> traverse (bitraverse f g) args <*> g as - bitraverse f g (ArrayRecordElem fs) = - ArrayRecordElem <$> traverse (bitraverse f g) fs - bitraverse _ g (ArrayEnumElem cs as) = - ArrayEnumElem cs <$> g as +instance Traversable ArrayElemTypeBase where + traverse _ (ArrayPrimElem t) = + pure $ ArrayPrimElem t + traverse f (ArrayPolyElem t args) = + ArrayPolyElem t <$> traverse (traverse f) args + traverse f (ArrayRecordElem fs) = + ArrayRecordElem <$> traverse (traverse f) fs + traverse _ (ArrayEnumElem cs) = + pure $ ArrayEnumElem cs -instance Bifunctor ArrayElemTypeBase where - bimap = bimapDefault +instance Functor ArrayElemTypeBase where + fmap = fmapDefault -instance Bifoldable ArrayElemTypeBase where - bifoldMap = bifoldMapDefault +instance Foldable ArrayElemTypeBase where + foldMap = foldMapDefault -- | An expanded Futhark type is either an array, a prim type, a -- tuple, or a type variable. When comparing types for equality with @@ -338,9 +337,9 @@ -- parameter names are ignored. data TypeBase dim as = Prim PrimType | Enum [Name] - | Array (ArrayElemTypeBase dim as) (ShapeDecl dim) Uniqueness + | Array as Uniqueness (ArrayElemTypeBase dim) (ShapeDecl dim) | Record (M.Map Name (TypeBase dim as)) - | TypeVar as Uniqueness TypeName [TypeArg dim as] + | TypeVar as Uniqueness TypeName [TypeArg dim] | Arrow as (Maybe VName) (TypeBase dim as) (TypeBase dim as) -- ^ The aliasing corresponds to the lexical -- closure of the function. @@ -348,7 +347,7 @@ instance (Eq dim, Eq as) => Eq (TypeBase dim as) where Prim x1 == Prim y1 = x1 == y1 - Array x1 y1 z1 == Array x2 y2 z2 = x1 == x2 && y1 == y2 && z1 == z2 + Array x1 y1 z1 v1 == Array x2 y2 z2 v2 = x1 == x2 && y1 == y2 && z1 == z2 && v1 == v2 Record x1 == Record x2 = x1 == x2 TypeVar _ u1 x1 y1 == TypeVar _ u2 x2 y2 = u1 == u2 && x1 == x2 && y1 == y2 Arrow _ _ x1 y1 == Arrow _ _ x2 y2 = x1 == x2 && y1 == y2 @@ -357,11 +356,11 @@ instance Bitraversable TypeBase where bitraverse _ _ (Prim t) = pure $ Prim t - bitraverse f g (Array a shape u) = - Array <$> bitraverse f g a <*> traverse f shape <*> pure u + bitraverse f g (Array a u t shape) = + Array <$> g a <*> pure u <*> traverse f t <*> traverse f shape bitraverse f g (Record fs) = Record <$> traverse (bitraverse f g) fs bitraverse f g (TypeVar als u t args) = - TypeVar <$> g als <*> pure u <*> pure t <*> traverse (bitraverse f g) args + TypeVar <$> g als <*> pure u <*> pure t <*> traverse (traverse f) args bitraverse f g (Arrow als v t1 t2) = Arrow <$> g als <*> pure v <*> bitraverse f g t1 <*> bitraverse f g t2 bitraverse _ _ (Enum n) = pure $ Enum n @@ -372,27 +371,39 @@ instance Bifoldable TypeBase where bifoldMap = bifoldMapDefault -data TypeArg dim as = TypeArgDim dim SrcLoc - | TypeArgType (TypeBase dim as) SrcLoc +data TypeArg dim = TypeArgDim dim SrcLoc + | TypeArgType (TypeBase dim ()) SrcLoc deriving (Eq, Show) -instance Bitraversable TypeArg where - bitraverse f _ (TypeArgDim v loc) = TypeArgDim <$> f v <*> pure loc - bitraverse f g (TypeArgType t loc) = TypeArgType <$> bitraverse f g t <*> pure loc +instance Traversable TypeArg where + traverse f (TypeArgDim v loc) = TypeArgDim <$> f v <*> pure loc + traverse f (TypeArgType t loc) = TypeArgType <$> bitraverse f pure t <*> pure loc -instance Bifunctor TypeArg where - bimap = bimapDefault +instance Functor TypeArg where + fmap = fmapDefault -instance Bifoldable TypeArg where - bifoldMap = bifoldMapDefault +instance Foldable TypeArg where + foldMap = foldMapDefault +-- | A variable that is aliased. Can be still in-scope, or have gone +-- out of scope and be free. In the latter case, it behaves more like +-- an equivalence class. See uniqueness-error18.fut for an example of +-- why this is necessary. +data Alias = AliasBound { aliasVar :: VName } + | AliasFree { aliasVar :: VName } + deriving (Eq, Ord, Show) + +-- | Aliasing for a type, which is a set of the variables that are +-- aliased. +type Aliasing = S.Set Alias + -- | A type with aliasing information and no shape annotations, used -- for describing the type of a computation. -type CompType = TypeBase () Names +type CompType = TypeBase () Aliasing -- | A type with aliasing information and shape annotations, used for -- describing the type of a pattern. -type PatternType = TypeBase (DimDecl VName) Names +type PatternType = TypeBase (DimDecl VName) Aliasing -- | An unstructured type with type variables and possibly shape -- declarations - this is what the user types in the source program. @@ -609,7 +620,7 @@ -- ^ Numeric negation (ugly special case; Haskell did it first). | Lambda [TypeParamBase vn] [PatternBase f vn] (ExpBase f vn) - (Maybe (TypeDeclBase f vn)) (f (Names, StructType)) SrcLoc + (Maybe (TypeDeclBase f vn)) (f (Aliasing, StructType)) SrcLoc | OpSection (QualName vn) (f PatternType) SrcLoc -- ^ @+@; first two types are operands, third is result. @@ -1006,9 +1017,6 @@ , progDecs :: [DecBase f vn] } deriving instance Showable f vn => Show (ProgBase f vn) - --- | A set of names. -type Names = S.Set VName --- Some prettyprinting definitions are here because we need them in --- the Attributes module. 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 @@ -223,9 +223,13 @@ maybe (return Nothing) (fmap Just . astMap tv) j <*> maybe (return Nothing) (fmap Just . astMap tv) stride -instance ASTMappable Names where - astMap tv = fmap S.fromList . traverse (mapOnName tv) . S.toList +instance ASTMappable Alias where + astMap tv (AliasBound v) = AliasBound <$> mapOnName tv v + astMap tv (AliasFree v) = AliasFree <$> mapOnName tv v +instance ASTMappable Aliasing where + astMap tv = fmap S.fromList . traverse (astMap tv) . S.toList + type TypeTraverser f t dim1 als1 dim2 als2 = (TypeName -> f TypeName) -> (dim1 -> f dim2) -> (als1 -> f als2) -> t dim1 als1 -> f (t dim2 als2) @@ -233,38 +237,40 @@ traverseType :: Applicative f => TypeTraverser f TypeBase dim1 als1 dims als2 traverseType _ _ _ (Prim t) = pure $ Prim t -traverseType f g h (Array et shape u) = - Array <$> traverseArrayElemType f g h et <*> traverse g shape <*> pure u +traverseType f g h (Array als u et shape) = + Array <$> h als <*> pure u <*> traverseArrayElemType f g et <*> traverse g shape traverseType f g h (Record fs) = Record <$> traverse (traverseType f g h) fs traverseType f g h (TypeVar als u t args) = - TypeVar <$> h als <*> pure u <*> f t <*> traverse (traverseTypeArg f g h) args + TypeVar <$> h als <*> pure u <*> f t <*> traverse (traverseTypeArg f g) args traverseType f g h (Arrow als v t1 t2) = Arrow <$> h als <*> pure v <*> traverseType f g h t1 <*> traverseType f g h t2 traverseType _ _ _ (Enum cs) = pure $ Enum cs traverseArrayElemType :: Applicative f => - TypeTraverser f ArrayElemTypeBase dim1 als1 dim2 als2 -traverseArrayElemType _ _ h (ArrayPrimElem t as) = - ArrayPrimElem t <$> h as -traverseArrayElemType f g h (ArrayPolyElem t args as) = - ArrayPolyElem <$> f t <*> traverse (traverseTypeArg f g h) args <*> h as -traverseArrayElemType f g h (ArrayRecordElem fs) = - ArrayRecordElem <$> traverse (traverseRecordArrayElemType f g h) fs -traverseArrayElemType _ _ h (ArrayEnumElem cs as) = - ArrayEnumElem cs <$> h as + (TypeName -> f TypeName) -> (dim1 -> f dim2) + -> ArrayElemTypeBase dim1 -> f (ArrayElemTypeBase dim2) +traverseArrayElemType _ _ (ArrayPrimElem t) = + pure $ ArrayPrimElem t +traverseArrayElemType f g (ArrayPolyElem t args) = + ArrayPolyElem <$> f t <*> traverse (traverseTypeArg f g) args +traverseArrayElemType f g (ArrayRecordElem fs) = + ArrayRecordElem <$> traverse (traverseRecordArrayElemType f g) fs +traverseArrayElemType _ _ (ArrayEnumElem cs) = + pure $ ArrayEnumElem cs traverseRecordArrayElemType :: Applicative f => - TypeTraverser f RecordArrayElemTypeBase dim1 als1 dim2 als2 -traverseRecordArrayElemType f g h (RecordArrayElem et) = - RecordArrayElem <$> traverseArrayElemType f g h et -traverseRecordArrayElemType f g h (RecordArrayArrayElem et shape u) = - RecordArrayArrayElem <$> traverseArrayElemType f g h et <*> - traverse g shape <*> pure u + (TypeName -> f TypeName) -> (dim1 -> f dim2) + -> RecordArrayElemTypeBase dim1 -> f (RecordArrayElemTypeBase dim2) +traverseRecordArrayElemType f g (RecordArrayElem et) = + RecordArrayElem <$> traverseArrayElemType f g et +traverseRecordArrayElemType f g (RecordArrayArrayElem et shape) = + RecordArrayArrayElem <$> traverseArrayElemType f g et <*> traverse g shape traverseTypeArg :: Applicative f => - TypeTraverser f TypeArg dim1 als1 dim2 als2 -traverseTypeArg _ g _ (TypeArgDim d loc) = TypeArgDim <$> g d <*> pure loc -traverseTypeArg f g h (TypeArgType t loc) = TypeArgType <$> traverseType f g h t <*> pure loc + (TypeName -> f TypeName) -> (dim1 -> f dim2) + -> TypeArg dim1 -> f (TypeArg dim2) +traverseTypeArg _ g (TypeArgDim d loc) = TypeArgDim <$> g d <*> pure loc +traverseTypeArg f g (TypeArgType t loc) = TypeArgType <$> traverseType f g pure t <*> pure loc instance ASTMappable (TypeBase () ()) where astMap tv = traverseType f pure pure diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs --- a/src/Language/Futhark/TypeChecker.hs +++ b/src/Language/Futhark/TypeChecker.hs @@ -8,6 +8,7 @@ ( checkProg , checkExp , checkDec + , checkModExp , TypeError , Warnings , initialEnv @@ -66,7 +67,7 @@ where files' = M.map fileEnv $ M.fromList files -- | Type check a single declaration containing no type information, --- yielding either a type error or the same expression annotated with +-- yielding either a type error or the same declaration annotated with -- type information along the Env produced by that declaration. See -- also 'checkProg'. checkDec :: Imports @@ -82,6 +83,20 @@ return (env', d', src') where files' = M.map fileEnv $ M.fromList files +-- | Type check a single module expression containing no type information, +-- yielding either a type error or the same expression annotated with +-- type information along the Env produced by that declaration. See +-- also 'checkProg'. +checkModExp :: Imports + -> VNameSource + -> Env + -> ModExpBase NoInfo Name + -> Either TypeError (MTy, ModExpBase Info VName) +checkModExp files src env me = do + (x, _, _) <- runTypeM env files' (mkInitialImport "") src $ checkOneModExp me + return x + where files' = M.map fileEnv $ M.fromList files + -- | An initial environment for the type checker, containing -- intrinsics and such. initialEnv :: Env @@ -162,7 +177,7 @@ name' <- checkName Term name loc (tparams', rettype') <- checkTypeParams tparams $ \tparams' -> bindingTypeParams tparams' $ do - (vtype', _) <- checkTypeDecl vtype + (vtype', _) <- checkTypeDecl tparams' vtype return (tparams', vtype') let binding = BoundV tparams' $ unInfo $ expandedType rettype' @@ -224,7 +239,7 @@ (lookupType loc qn >> warnAbout qn) `catchError` \_ -> return () warnAbout qn = - warn loc $ "Inclusion shadows type `" ++ pretty qn ++ "`." + warn loc $ "Inclusion shadows type " ++ quote (pretty qn) ++ "." checkSigExp :: SigExpBase NoInfo Name -> TypeM (MTy, SigExpBase Info VName) checkSigExp (SigParens e loc) = do @@ -241,7 +256,7 @@ checkSigExp (SigWith s (TypeRef tname ps td trloc) loc) = do (s_abs, s_env, s') <- checkSigExpToEnv s checkTypeParams ps $ \ps' -> do - (td', _) <- bindingTypeParams ps' $ checkTypeDecl td + (td', _) <- bindingTypeParams ps' $ checkTypeDecl ps' td (tname', s_abs', s_env') <- refineEnv loc s_abs s_env tname ps' $ unInfo $ expandedType td' return (MTy s_abs' $ ModEnv s_env', SigWith s' (TypeRef tname' ps' td' trloc) loc) checkSigExp (SigArrow maybe_pname e1 e2 loc) = do @@ -277,48 +292,48 @@ }, SigBind name' e' doc loc) -checkModExp :: ModExpBase NoInfo Name -> TypeM (MTy, ModExpBase Info VName) -checkModExp (ModParens e loc) = do - (mty, e') <- checkModExp e +checkOneModExp :: ModExpBase NoInfo Name -> TypeM (MTy, ModExpBase Info VName) +checkOneModExp (ModParens e loc) = do + (mty, e') <- checkOneModExp e return (mty, ModParens e' loc) -checkModExp (ModDecs decs loc) = do +checkOneModExp (ModDecs decs loc) = do checkForDuplicateDecs decs (abstypes, env, decs') <- checkDecs decs return (MTy abstypes $ ModEnv env, ModDecs decs' loc) -checkModExp (ModVar v loc) = do +checkOneModExp (ModVar v loc) = do (v', env) <- lookupMod loc v when (baseName (qualLeaf v') == nameFromString "intrinsics" && baseTag (qualLeaf v') <= maxIntrinsicTag) $ throwError $ TypeError loc "The 'intrinsics' module may not be used in module expressions." return (MTy mempty env, ModVar v' loc) -checkModExp (ModImport name NoInfo loc) = do +checkOneModExp (ModImport name NoInfo loc) = do (name', env) <- lookupImport loc name return (MTy mempty $ ModEnv env, ModImport name (Info name') loc) -checkModExp (ModApply f e NoInfo NoInfo loc) = do - (f_mty, f') <- checkModExp f +checkOneModExp (ModApply f e NoInfo NoInfo loc) = do + (f_mty, f') <- checkOneModExp f case mtyMod f_mty of ModFun functor -> do - (e_mty, e') <- checkModExp e + (e_mty, e') <- checkOneModExp e (mty, psubsts, rsubsts) <- applyFunctor loc functor e_mty return (mty, ModApply f' e' (Info psubsts) (Info rsubsts) loc) _ -> throwError $ TypeError loc "Cannot apply non-parametric module." -checkModExp (ModAscript me se NoInfo loc) = do - (me_mod, me') <- checkModExp me +checkOneModExp (ModAscript me se NoInfo loc) = do + (me_mod, me') <- checkOneModExp me (se_mty, se') <- checkSigExp se match_subst <- badOnLeft $ matchMTys me_mod se_mty loc return (se_mty, ModAscript me' se' (Info match_subst) loc) -checkModExp (ModLambda param maybe_fsig_e body_e loc) = +checkOneModExp (ModLambda param maybe_fsig_e body_e loc) = withModParam param $ \param' param_abs param_mod -> do (maybe_fsig_e', body_e', mty) <- checkModBody (fst <$> maybe_fsig_e) body_e loc return (MTy mempty $ ModFun $ FunSig param_abs param_mod mty, ModLambda param' maybe_fsig_e' body_e' loc) -checkModExpToEnv :: ModExpBase NoInfo Name -> TypeM (TySet, Env, ModExpBase Info VName) -checkModExpToEnv e = do - (MTy abs mod, e') <- checkModExp e +checkOneModExpToEnv :: ModExpBase NoInfo Name -> TypeM (TySet, Env, ModExpBase Info VName) +checkOneModExpToEnv e = do + (MTy abs mod, e') <- checkOneModExp e case mod of ModEnv env -> return (abs, env, e') ModFun{} -> unappliedFunctor $ srclocOf e @@ -348,7 +363,7 @@ -> TypeM (Maybe (SigExp, Info (M.Map VName VName)), ModExp, MTy) checkModBody maybe_fsig_e body_e loc = do - (body_mty, body_e') <- checkModExp body_e + (body_mty, body_e') <- checkOneModExp body_e case maybe_fsig_e of Nothing -> return (Nothing, body_e', body_mty) @@ -430,7 +445,7 @@ -> TypeM (Env, TypeBindBase Info VName) checkTypeBind (TypeBind name ps td doc loc) = checkTypeParams ps $ \ps' -> do - (td', l) <- bindingTypeParams ps' $ checkTypeDecl td + (td', l) <- bindingTypeParams ps' $ checkTypeDecl ps' td bindSpaced [(Type, name)] $ do name' <- checkName Type name loc return (mempty { envTypeTable = @@ -516,7 +531,7 @@ return (mempty, tenv, TypeDec tdec') checkOneDec (OpenDec x loc) = do - (x_abs, x_env, x') <- checkModExpToEnv x + (x_abs, x_env, x') <- checkOneModExpToEnv x return (x_abs, x_env, OpenDec x' loc) checkOneDec (LocalDec d loc) = do @@ -675,7 +690,7 @@ matchVal loc spec_name spec_t name t | matchFunBinding loc spec_t t = return (spec_name, name) matchVal loc spec_name spec_v _ v = - Left $ TypeError loc $ "Value `" ++ baseString spec_name ++ "` specified as type " ++ + Left $ TypeError loc $ "Value " ++ quote (baseString spec_name) ++ " specified as type " ++ ppValBind spec_v ++ " in signature, but has " ++ ppValBind v ++ " in structure." matchFunBinding :: SrcLoc -> BoundV -> BoundV -> Bool @@ -867,20 +882,20 @@ Record $ fmap substituteInType ts substituteInType (Enum cs) = Enum cs - substituteInType (Array (ArrayPrimElem t ()) shape u) = - Array (ArrayPrimElem t ()) (substituteInShape shape) u - substituteInType (Array (ArrayPolyElem (TypeName qs v) targs ()) shape u) = - Array (ArrayPolyElem - (TypeName (map substitute qs) $ substitute v) - (map substituteInTypeArg targs) ()) - (substituteInShape shape) u - substituteInType (Array (ArrayRecordElem ts) shape u) = - let ts' = fmap (substituteInType . fst . recordArrayElemToType) ts + substituteInType (Array () u (ArrayPrimElem t) shape) = + Array () u (ArrayPrimElem t) (substituteInShape shape) + substituteInType (Array () u (ArrayPolyElem (TypeName qs v) targs) shape) = + Array () u (ArrayPolyElem + (TypeName (map substitute qs) $ substitute v) + (map substituteInTypeArg targs)) + (substituteInShape shape) + substituteInType (Array () u (ArrayRecordElem ts) shape) = + let ts' = fmap (substituteInType . recordArrayElemToType) ts in case arrayOf (Record ts') (substituteInShape shape) u of Just t' -> t' _ -> error "substituteInType: Cannot create array after substitution." - substituteInType (Array (ArrayEnumElem cs ()) shape u) = - Array (ArrayEnumElem cs ()) (substituteInShape shape) u + substituteInType (Array () u (ArrayEnumElem cs) shape) = + Array () u (ArrayEnumElem cs) (substituteInShape shape) substituteInType (Arrow als v t1 t2) = Arrow als v (substituteInType t1) (substituteInType t2) 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 @@ -27,6 +27,7 @@ , MonadTypeChecker(..) , checkName , badOnLeft + , quote , module Language.Futhark.Warnings @@ -337,6 +338,12 @@ badOnLeft :: MonadTypeChecker m => Either TypeError a -> m a badOnLeft = either throwError return + +-- | Enclose a string in the prefered quotes used in error messages. +-- These are picked to not collide with characters permitted in +-- identifiers. +quote :: String -> String +quote s = "`" ++ s ++ "`" anySignedType :: [PrimType] anySignedType = map Signed [minBound .. maxBound] 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 @@ -22,7 +22,6 @@ import Data.List import Data.Loc import Data.Maybe -import qualified Data.Semigroup as Sem import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -43,6 +42,8 @@ | Observed SrcLoc deriving (Eq, Ord, Show) +type Names = S.Set VName + -- | The consumption set is a Maybe so we can distinguish whether a -- consumption took place, but the variable went out of scope since, -- or no consumption at all took place. @@ -55,11 +56,11 @@ instance Located Occurence where locOf = locOf . location -observation :: Names -> SrcLoc -> Occurence -observation = flip Occurence Nothing +observation :: Aliasing -> SrcLoc -> Occurence +observation = flip Occurence Nothing . S.map aliasVar -consumption :: Names -> SrcLoc -> Occurence -consumption = Occurence S.empty . Just +consumption :: Aliasing -> SrcLoc -> Occurence +consumption = Occurence S.empty . Just . S.map aliasVar -- | A null occurence is one that we can remove without affecting -- anything. @@ -131,7 +132,11 @@ --- Scope management -data ValBinding = BoundV [TypeParam] PatternType +-- | Whether something is a global or a local variable. +data Locality = Local | Global + deriving (Show) + +data ValBinding = BoundV Locality [TypeParam] PatternType -- ^ Aliases in parameters indicate the lexical -- closure. | OverloadedF [PrimType] [Maybe PrimType] (Maybe PrimType) @@ -150,18 +155,19 @@ -- ^ Most recent first. } deriving (Show) -instance Sem.Semigroup TermScope where +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 - mappend = (Sem.<>) envToTermScope :: Env -> TermScope envToTermScope env = TermScope vtable (envTypeTable env) (envNameMap env) mempty - where vtable = M.map valBinding $ envVtable env - valBinding (TypeM.BoundV tps v) = BoundV tps $ v `setAliases` mempty + 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) constraintTypeVars :: Constraints -> Names constraintTypeVars = mconcat . map f . M.elems @@ -234,11 +240,11 @@ funF ts t = foldr (Arrow mempty Nothing . Prim) (Prim t) ts addIntrinsicF (name, IntrinsicMonoFun ts t) = - Just (name, BoundV [] $ funF ts t) + Just (name, BoundV Global [] $ funF ts t) addIntrinsicF (name, IntrinsicOverloadedFun ts pts rts) = Just (name, OverloadedF ts pts rts) addIntrinsicF (name, IntrinsicPolyFun tvs pts rt) = - Just (name, BoundV tvs $ + Just (name, BoundV Global tvs $ fromStruct $ vacuousShapeAnnotations $ Arrow mempty Nothing pts' rt) where pts' = case pts of [pt] -> pt @@ -287,11 +293,12 @@ (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Term qn loc t <- case M.lookup name $ scopeVtable scope of - Nothing -> unknownVariableError Term qn loc + Nothing -> throwError $ TypeError loc $ + "Missing component for module " ++ quote (pretty qn) ++ "." Just (WasConsumed wloc) -> useAfterConsume (baseName name) loc wloc - Just (BoundV tparams t) + Just (BoundV _ tparams t) | "_" `isPrefixOf` baseString name -> underscoreUse loc qn | otherwise -> do (tnames, t') <- instantiateTypeScheme loc tparams t @@ -350,11 +357,11 @@ (env, name') <- liftTypeM $ TypeM.checkQualNameWithEnv space qn loc return (envToTermScope env, name') --- | Wrap 'checkTypeDecl' to also perform an observation of every size --- in the type. +-- | Wrap 'Types.checkTypeDecl' to also perform an observation of +-- every size in the type. checkTypeDecl :: TypeDeclBase NoInfo Name -> TermTypeM (TypeDeclBase Info VName) checkTypeDecl tdecl = do - (tdecl', _) <- Types.checkTypeDecl tdecl + (tdecl', _) <- Types.checkTypeDecl [] tdecl mapM_ observeDim $ nestedDims $ unInfo $ expandedType tdecl' return tdecl' where observeDim (NamedDim v) = observe $ Ident (qualLeaf v) (Info $ Prim $ Signed Int32) noLoc @@ -389,8 +396,8 @@ newArrayType loc desc r = do v <- newID $ nameFromString desc modifyConstraints $ M.insert v $ NoConstraint Nothing loc - return (Array (ArrayPolyElem (typeName v) [] ()) - (ShapeDecl $ replicate r ()) Nonunique, + return (Array () Nonunique + (ArrayPolyElem (typeName v) []) (ShapeDecl $ replicate r ()), TypeVar () Nonunique (typeName v) []) --- Errors @@ -438,29 +445,29 @@ unifyTypeAliases :: CompType -> CompType -> CompType unifyTypeAliases t1 t2 = case (t1, t2) of - (Array et1 shape1 u1, Array et2 _ u2) -> - Array (unifyArrayElems et1 et2) shape1 $ min u1 u2 + (Array als1 u1 et1 shape1, Array als2 u2 et2 _) -> + Array (als1<>als2) (min u1 u2) (unifyArrayElems et1 et2) shape1 (Record f1, Record f2) -> Record $ M.intersectionWith unifyTypeAliases f1 f2 (TypeVar als1 u v targs1, TypeVar als2 _ _ targs2) -> TypeVar (als1 <> als2) u v $ zipWith unifyTypeArg targs1 targs2 _ -> t1 - where unifyArrayElems (ArrayPrimElem pt1 als1) (ArrayPrimElem _ als2) = - ArrayPrimElem pt1 $ als1 <> als2 - unifyArrayElems (ArrayPolyElem v targs1 als1) (ArrayPolyElem _ targs2 als2) = - ArrayPolyElem v (zipWith unifyTypeArg targs1 targs2) $ als1 <> als2 + where unifyArrayElems (ArrayPrimElem pt1) (ArrayPrimElem _) = + ArrayPrimElem pt1 + unifyArrayElems (ArrayPolyElem v targs1) (ArrayPolyElem _ _targs2) = + ArrayPolyElem v targs1 unifyArrayElems (ArrayRecordElem fields1) (ArrayRecordElem fields2) = ArrayRecordElem $ M.intersectionWith unifyRecordArray fields1 fields2 unifyArrayElems x _ = x unifyRecordArray (RecordArrayElem at1) (RecordArrayElem at2) = RecordArrayElem $ unifyArrayElems at1 at2 - unifyRecordArray (RecordArrayArrayElem at1 shape1 u1) (RecordArrayArrayElem at2 _ u2) = - RecordArrayArrayElem (unifyArrayElems at1 at2) shape1 $ min u1 u2 + unifyRecordArray (RecordArrayArrayElem at1 shape1) (RecordArrayArrayElem at2 _) = + RecordArrayArrayElem (unifyArrayElems at1 at2) shape1 unifyRecordArray x _ = x - unifyTypeArg (TypeArgType t1' loc) (TypeArgType t2' _) = - TypeArgType (unifyTypeAliases t1' t2') loc + unifyTypeArg (TypeArgType t1' loc) (TypeArgType _ _) = + TypeArgType t1' loc unifyTypeArg a _ = a --- General binding. @@ -477,9 +484,7 @@ checkPattern' (Id name NoInfo loc) (Ascribed t) = do name' <- checkName Term name loc - let t' = case t of Record{} -> t - _ -> t `addAliases` S.insert name' - return $ Id name' (Info t') loc + return $ Id name' (Info t) loc checkPattern' (Id name NoInfo loc) NoneInferred = do name' <- checkName Term name loc t <- newTypeVar loc "t" @@ -537,8 +542,8 @@ PatternAscription <$> checkPattern' p (Ascribed outer_t'') <*> pure (TypeDecl t' (Info st)) <*> pure loc Nothing -> - typeError loc $ "Cannot match type `" ++ pretty outer_t' ++ "' with expected type `" ++ - pretty st'' ++ "'." + typeError loc $ "Cannot match type " ++ quote (pretty outer_t') ++ " with expected type " ++ + quote (pretty st'') ++ "." NoneInferred -> PatternAscription <$> checkPattern' p (Ascribed st') <*> @@ -574,15 +579,17 @@ bindVar :: TermScope -> Ident -> TermScope bindVar scope (Ident name (Info tp) _) = - let inedges = S.toList $ aliases tp - update (BoundV tparams tp') + let inedges = boundAliases $ aliases tp + update (BoundV l tparams in_t) -- If 'name' is record-typed, don't alias the components -- to 'name', because records have no identity beyond -- their components. - | Record _ <- tp = BoundV tparams tp' - | otherwise = BoundV tparams (tp' `addAliases` S.insert name) + | Record _ <- tp = BoundV l tparams in_t + | otherwise = BoundV l tparams (in_t `addAliases` S.insert (AliasBound name)) update b = b - in scope { scopeVtable = M.insert name (BoundV [] $ vacuousShapeAnnotations tp) $ + + tp' = vacuousShapeAnnotations tp `addAliases` S.insert (AliasBound name) + in scope { scopeVtable = M.insert name (BoundV Local [] tp') $ adjustSeveral update inedges $ scopeVtable scope } @@ -661,7 +668,7 @@ -- dimensions. mapM_ observe $ mapMaybe typeParamIdent tps' let ps'' = reverse ps' - checkShapeParamUses tps' ps'' + checkShapeParamUses patternUses tps' ps'' m tps' ps'' @@ -677,31 +684,10 @@ -- Perform an observation of every declared dimension. This -- prevents unused-name warnings for otherwise unused dimensions. mapM_ observe $ patternDims p' - checkShapeParamUses tps' [p'] + checkShapeParamUses patternUses tps' [p'] m tps' p' --- | Ensure that every shape parameter is used in positive position at --- least once before being used in negative position. -checkShapeParamUses :: [TypeParam] -> [Pattern] -> TermTypeM () -checkShapeParamUses tps ps = do - pos_uses <- foldM checkShapePositions [] ps - mapM_ (checkUsed pos_uses) tps - where checkShapePositions pos_uses p = do - let (pos, neg) = patternUses p - pos_uses' = pos <> pos_uses - forM_ neg (\pv -> unless (pv `elem` pos_uses') $ - typeError (srclocOf p) $ "Shape parameter " ++ - pretty (baseName pv) ++ " must first be given in " ++ - "a positive position (non-functional parameter).") - return pos_uses' - checkUsed uses (TypeParamDim pv loc) - | pv `elem` uses = return () - | otherwise = - typeError loc $ "Size parameter " ++ - pretty (baseName pv) ++ " not used in any value parameters." - checkUsed _ _ = return () - -- | Return the shapes used in a given pattern in postive and negative -- position, respectively. patternUses :: Pattern -> ([VName], [VName]) @@ -713,22 +699,7 @@ patternUses (RecordPattern fs _) = foldMap (patternUses . snd) fs patternUses (PatternAscription p (TypeDecl declte _) _) = patternUses p <> typeExpUses declte - where typeExpUses (TEVar _ _) = mempty - typeExpUses (TETuple tes _) = foldMap typeExpUses tes - typeExpUses (TERecord fs _) = foldMap (typeExpUses . snd) fs - typeExpUses (TEArray te d _) = typeExpUses te <> dimDeclUses d - typeExpUses (TEUnique te _) = typeExpUses te - typeExpUses (TEApply te targ _) = typeExpUses te <> typeArgUses targ - typeExpUses (TEArrow _ t1 t2 _) = - let (pos, neg) = typeExpUses t1 <> typeExpUses t2 - in (mempty, pos <> neg) - typeExpUses TEEnum{} = mempty - typeArgUses (TypeArgExpDim d _) = dimDeclUses d - typeArgUses (TypeArgExpType te) = typeExpUses te - dimDeclUses (NamedDim v) = ([qualLeaf v], []) - dimDeclUses _ = mempty - noTypeParamsPermitted :: [UncheckedTypeParam] -> TermTypeM () noTypeParamsPermitted ps = case mapMaybe typeParamLoc ps of @@ -760,6 +731,18 @@ unify (srclocOf e) t =<< toStruct <$> expType e return e +-- The closure of a lambda or local function are those variables that +-- it references, and which local to the current top-level function. +lexicalClosure :: [Pattern] -> Occurences -> TermTypeM Aliasing +lexicalClosure params closure = do + vtable <- asks scopeVtable + let isLocal v = case v `M.lookup` vtable of + Just (BoundV Local _ _) -> True + _ -> False + return $ S.map AliasBound $ S.filter isLocal $ + allOccuring closure S.\\ + S.map identName (mconcat (map patIdentSet params)) + checkExp :: UncheckedExp -> TermTypeM Exp checkExp (Literal val loc) = @@ -879,7 +862,7 @@ sequentially checkCond $ \e1' _ -> do ((e2', e3'), dflow) <- tapOccurences $ checkExp e2 `alternative` checkExp e3 brancht <- unifyExpTypes e2' e3' - let t' = addAliases brancht (`S.difference` allConsumed dflow) + let t' = addAliases brancht (`S.difference` S.map AliasBound (allConsumed dflow)) zeroOrderType loc "returned from branch" t' return $ If e1' e2' e3' (Info t') loc where checkCond = do @@ -911,7 +894,9 @@ -- end until we find a module. (qn', t, fields) <- findRootVar (qualQuals qn) (qualLeaf qn) - foldM checkField (Var qn' (Info (vacuousShapeAnnotations t)) loc) fields + + foldM checkField (Var qn' (Info $ vacuousShapeAnnotations t) loc) fields + where findRootVar qs name = (whenFound <$> lookupVar loc (QualName qs name)) `catchError` notFound qs name @@ -959,8 +944,10 @@ sequentially (checkFunDef' (name, maybe_retdecl, tparams, params, e, loc)) $ \(name', tparams', params', maybe_retdecl', rettype, e') closure -> do + closure' <- lexicalClosure params' closure + let ftype = foldr (uncurry (Arrow ()) . patternParam) rettype params' - entry = BoundV tparams' $ ftype `setAliases` allOccuring closure + 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 } @@ -978,13 +965,13 @@ void $ unifies t src'' unless (unique $ unInfo $ identType src') $ - typeError pos $ "Source '" ++ pretty (identName src) ++ - "' has type " ++ pretty (unInfo $ identType src') ++ ", which is not unique" + typeError pos $ "Source " ++ quote (pretty (identName src)) ++ + " has type " ++ pretty (unInfo $ identType src') ++ ", which is not unique" idxes' <- mapM checkDimIndex idxes sequentially (unifies elemt =<< checkExp ve) $ \ve' _ -> do ve_t <- expType ve' - when (identName src' `S.member` aliases ve_t) $ + when (AliasBound (identName src') `S.member` aliases ve_t) $ badLetWithValue pos bindingIdent dest (unInfo (identType src') `setAliases` S.empty) $ \dest' -> do @@ -1003,8 +990,8 @@ src_t <- expType src' unless (unique src_t) $ - typeError loc $ "Source '" ++ pretty src ++ - "' has type " ++ pretty src_t ++ ", which is not unique" + typeError loc $ "Source " ++ quote (pretty src) ++ + " has type " ++ pretty src_t ++ ", which is not unique" let src_als = aliases src_t ve_t <- expType ve' @@ -1039,24 +1026,25 @@ e' <- checkInput e es' <- mapM checkInput es - ts <- forM (e':es') $ \arr_e -> do - arr_e_t <- expType arr_e - case typeToRecordArrayElem' (aliases arr_e_t) =<< peelArray (i+1) arr_e_t of + e_ts <- mapM expType $ e':es' + ts <- forM (zip (e':es') e_ts) $ \(arr_e, arr_e_t) -> + case typeToRecordArrayElem =<< peelArray (i+1) arr_e_t of Just t -> return t Nothing -> typeError (srclocOf arr_e) $ "Expected array with at least " ++ show (1+i) ++ " dimensions, but got " ++ pretty arr_e_t ++ "." let u = mconcat $ map (uniqueness . typeOf) $ e':es' - t = Array (ArrayRecordElem $ M.fromList $ zip tupleFieldNames ts) - (rank (1+i)) u + t = Array (mconcat $ map aliases e_ts) u + (ArrayRecordElem $ M.fromList $ zip tupleFieldNames ts) + (rank (1+i)) return $ Zip i e' es' (Info t) loc checkExp (Unzip e _ loc) = do e' <- checkExp e e_t <- expType e' case e_t of - Array (ArrayRecordElem fs) shape u + Array _ u (ArrayRecordElem fs) shape | Just ets <- map (componentType shape u) <$> areTupleFields fs -> return $ Unzip e' (map Info ets) loc t -> @@ -1066,9 +1054,9 @@ where componentType shape u et = case et of RecordArrayElem et' -> - Array et' shape u - RecordArrayArrayElem et' et_shape et_u -> - Array et' (shape <> et_shape) (u `max` et_u) + Array mempty u et' shape + RecordArrayArrayElem et' et_shape -> + Array mempty u et' (shape <> et_shape) checkExp (Unsafe e loc) = Unsafe <$> checkExp e <*> pure loc @@ -1096,13 +1084,15 @@ Just retdecl'@(TypeDecl _ (Info st)) -> return (Just retdecl', st) Nothing -> do body_t <- expType body' - return (Nothing, vacuousShapeAnnotations $ toStruct body_t) - return $ Lambda tparams' params' body' maybe_retdecl'' - (Info (allOccuring closure, rettype)) loc + return (Nothing, inferReturnUniqueness params' body_t) + closure' <- lexicalClosure params' closure + + return $ Lambda tparams' params' body' maybe_retdecl'' (Info (closure', rettype)) loc + checkExp (OpSection op _ loc) = do (op', ftype) <- lookupVar loc op - return $ OpSection op' (Info (vacuousShapeAnnotations ftype)) loc + return $ OpSection op' (Info $ vacuousShapeAnnotations ftype) loc checkExp (OpSectionLeft op _ e _ _ loc) = do (op', ftype) <- lookupVar loc op @@ -1261,7 +1251,7 @@ bound_outside <- asks $ S.fromList . M.keys . scopeVtable let checkMergeReturn (Id pat_v (Info pat_v_t) _) t | unique pat_v_t, - v:_ <- S.toList $ aliases t `S.intersection` bound_outside = + v:_ <- S.toList $ S.map aliasVar (aliases t) `S.intersection` bound_outside = lift $ typeError loc $ "Loop return value corresponding to merge parameter " ++ prettyName pat_v ++ " aliases " ++ prettyName v ++ "." | otherwise = do @@ -1281,8 +1271,8 @@ checkMergeReturn _ _ = return () (pat_cons, _) <- execStateT (checkMergeReturn pat' body_t') (mempty, mempty) - let body_cons' = body_cons <> pat_cons - if body_cons' == body_cons && patternType pat' == patternType pat + let body_cons' = body_cons <> S.map aliasVar pat_cons + if body_cons' == body_cons && patternPatternType pat' == patternPatternType pat then return pat' else convergePattern pat' body_cons' body_t' body_loc @@ -1312,7 +1302,8 @@ (((c', c_t), (cs', cs_t)), dflow) <- tapOccurences $ checkCase mt c `alternative` checkCases mt c2 cs unify (srclocOf c) (toStruct c_t) (toStruct cs_t) - let t = unifyTypeAliases c_t cs_t `addAliases` (`S.difference` allConsumed dflow) + let t = unifyTypeAliases c_t cs_t `addAliases` + (`S.difference` S.map AliasBound (allConsumed dflow)) return (c':cs', t) checkCase :: CompType -> CaseBase NoInfo Name @@ -1510,10 +1501,8 @@ _ -> return () occur $ dflow `seqOccurences` occurs - - return (vacuousShapeAnnotations tp1', - vacuousShapeAnnotations $ - returnType (toStruct tp2') [diet tp1'] [argtype']) + let tp2'' = vacuousShapeAnnotations $ returnType tp2' (diet tp1') argtype' + return (vacuousShapeAnnotations tp1', tp2'') checkApply loc tfun@TypeVar{} arg = do tv <- newTypeVar loc "b" @@ -1529,12 +1518,12 @@ consumeArg :: SrcLoc -> CompType -> Diet -> TermTypeM [Occurence] consumeArg loc (Record ets) (RecordDiet ds) = concat . M.elems <$> traverse (uncurry $ consumeArg loc) (M.intersectionWith (,) ets ds) -consumeArg loc (Array _ _ Nonunique) Consume = +consumeArg loc (Array _ Nonunique _ _) Consume = typeError loc "Consuming parameter passed non-unique argument." consumeArg loc (Arrow _ _ t1 _) (FuncDiet d _) | not $ contravariantArg t1 d = typeError loc "Non-consuming higher-order parameter passed consuming argument." - where contravariantArg (Array _ _ Unique) Observe = + where contravariantArg (Array _ Unique _ _) Observe = False contravariantArg (TypeVar _ Unique _ _) Observe = False @@ -1559,6 +1548,8 @@ return (tparams, e'') -- | Type-check a top-level (or module-level) function definition. +-- Despite the name, this is also used for checking constant +-- definitions, by treating them as 0-ary functions. checkFunDef :: (Name, Maybe UncheckedTypeExp, [UncheckedTypeParam], [UncheckedPattern], UncheckedExp, SrcLoc) @@ -1643,14 +1634,35 @@ Just (retdecl', retdecl_type, _) -> do let rettype_structural = toStructural retdecl_type checkReturnAlias rettype_structural params'' body_t + + when (null params) $ nothingMustBeUnique loc rettype_structural + return (Just retdecl', retdecl_type) - Nothing -> return (Nothing, vacuousShapeAnnotations $ toStruct body_t) + Nothing + | null params -> + return (Nothing, vacuousShapeAnnotations $ toStruct $ body_t `setUniqueness` Nonunique) + | otherwise -> + return (Nothing, inferReturnUniqueness params'' body_t) tparams'' <- letGeneralise tparams' (rettype : map patternStructType params'') then_substs bindSpaced [(Term, fname)] $ do fname' <- checkName Term fname loc - return (fname', tparams'', params'', maybe_retdecl'', rettype, body') + vtable <- asks scopeVtable + let isLocal v = case v `M.lookup` vtable of + Just (BoundV Local _ _) -> True + _ -> False + let als = filter (not . isLocal) $ S.toList $ + boundArrayAliases body_t `S.difference` + S.map identName (mconcat (map patIdentSet params')) + case als of + v:_ | not $ null params -> + typeError loc $ + unlines [ "Function result aliases the free variable " <> + quote (prettyName v) <> "." + , "Use " ++ quote "copy" ++ " to break the aliasing."] + _ -> + return (fname', tparams'', params'', maybe_retdecl'', rettype, body') where -- | Check that unique return values do not alias a -- non-consumed parameter. @@ -1658,10 +1670,10 @@ foldM_ (checkReturnAlias' params') S.empty . returnAliasing rettp checkReturnAlias' params' seen (Unique, names) | any (`S.member` S.map snd seen) $ S.toList names = - uniqueReturnAliased fname loc + uniqueReturnAliased fname loc | otherwise = do - notAliasingParam params' names - return $ seen `S.union` tag Unique names + notAliasingParam params' names + return $ seen `S.union` tag Unique names checkReturnAlias' _ seen (Nonunique, names) | any (`S.member` seen) $ S.toList $ tag Unique names = uniqueReturnAliased fname loc @@ -1681,8 +1693,59 @@ returnAliasing (Record ets1) (Record ets2) = concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2 - returnAliasing expected got = [(uniqueness expected, aliases got)] + returnAliasing expected got = + [(uniqueness expected, S.map aliasVar $ aliases got)] +inferReturnUniqueness :: [Pattern] -> CompType -> StructType +inferReturnUniqueness params t = + let forbidden = aliasesMultipleTimes t + uniques = uniqueParamNames params + delve (Record fs) = + Record $ M.map delve fs + delve t' + | all (`S.member` uniques) (boundArrayAliases t'), + not $ any ((`S.member` forbidden) . aliasVar) (aliases t') = + toStruct t' + | otherwise = + toStruct $ t' `setUniqueness` Nonunique + in vacuousShapeAnnotations $ delve t + +-- An alias inhibits uniqueness if it is used in disjoint values. +aliasesMultipleTimes :: CompType -> Names +aliasesMultipleTimes = S.fromList . map fst . filter ((>1) . snd) . M.toList . delve + where delve (Record fs) = + foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs + delve t = + M.fromList $ zip (map aliasVar $ S.toList (aliases t)) $ repeat (1::Int) + +uniqueParamNames :: [Pattern] -> Names +uniqueParamNames = + S.fromList . map identName + . filter (unique . unInfo . identType) + . S.toList . mconcat . map patIdentSet + +boundArrayAliases :: CompType -> S.Set VName +boundArrayAliases (Array als _ _ _) = boundAliases als +boundArrayAliases Prim{} = mempty +boundArrayAliases Enum{} = mempty +boundArrayAliases (Record fs) = foldMap boundArrayAliases fs +boundArrayAliases (TypeVar als _ _ _) = boundAliases als +boundArrayAliases Arrow{} = mempty + +-- | The set of in-scope variables that are being aliased. +boundAliases :: Aliasing -> S.Set VName +boundAliases = S.map aliasVar . S.filter bound + where bound AliasBound{} = True + bound AliasFree{} = False + +nothingMustBeUnique :: SrcLoc -> TypeBase () () -> TermTypeM () +nothingMustBeUnique loc = check + where check (Array _ Unique _ _) = bad + check (TypeVar _ Unique _ _) = bad + check (Record fs) = mapM_ check fs + check _ = return () + bad = typeError loc "A top-level constant cannot have a unique type." + letGeneralise :: [TypeParam] -> [StructType] -> Constraints @@ -1733,9 +1796,9 @@ rettype_structural' <- normaliseType rettype_structural body_t <- expType body' unless (body_t `subtypeOf` rettype_structural') $ - typeError (srclocOf body) $ "Body type `" ++ pretty body_t ++ - "' is not a subtype of annotated type `" ++ - pretty rettype_structural' ++ "'." + typeError (srclocOf body) $ "Body type " ++ quote (pretty body_t) ++ + " is not a subtype of annotated type " ++ + quote (pretty rettype_structural') ++ "." Nothing -> return () @@ -1759,8 +1822,8 @@ k `elem` map typeParamName tparams = return () | otherwise = typeError (srclocOf v) $ - unlines ["Type variable `" ++ prettyName k ++ - "' not closed over by type parameters " ++ + unlines ["Type variable " ++ quote (prettyName k) ++ + " not closed over by type parameters " ++ intercalate ", " (map pretty tparams) ++ ".", "This is usually because a parameter needs a type annotation."] @@ -1779,19 +1842,29 @@ -- | Proclaim that we have made read-only use of the given variable. observe :: Ident -> TermTypeM () observe (Ident nm (Info t) loc) = - let als = nm `S.insert` aliases t + let als = AliasBound nm `S.insert` aliases t in occur [observation als loc] -- | Proclaim that we have written to the given variable. -consume :: SrcLoc -> Names -> TermTypeM () -consume loc als = occur [consumption als loc] +consume :: SrcLoc -> Aliasing -> TermTypeM () +consume loc als = do + vtable <- asks scopeVtable + let consumable v = case M.lookup v vtable of + Just (BoundV Local _ t) + | arrayRank t > 0 -> unique t + | otherwise -> True + _ -> False + case filter (not . consumable) $ map aliasVar $ S.toList als of + v:_ -> typeError loc $ "Attempt to consume variable " ++ quote (prettyName v) + ++ ", which is not allowed." + [] -> occur [consumption als loc] -- | Proclaim that we have written to the given variable, and mark -- accesses to it and all of its aliases as invalid inside the given -- computation. consuming :: Ident -> TermTypeM a -> TermTypeM a consuming (Ident name (Info t) loc) m = do - consume loc $ name `S.insert` aliases t + consume loc $ AliasBound name `S.insert` aliases t local consume' m where consume' scope = scope { scopeVtable = M.insert name (WasConsumed loc) $ scopeVtable scope } @@ -1811,7 +1884,7 @@ checkIfUsed occs v | not $ identName v `S.member` allOccuring occs, not $ "_" `isPrefixOf` prettyName (identName v) = - warn (srclocOf v) $ "Unused variable '"++pretty (baseName $ identName v)++"'." + warn (srclocOf v) $ "Unused variable " ++ quote (pretty $ baseName $ identName v) ++ "." | otherwise = return () @@ -1827,7 +1900,7 @@ -- | Make all bindings nonunique. noUnique :: TermTypeM a -> TermTypeM a noUnique = local (\scope -> scope { scopeVtable = M.map set $ scopeVtable scope}) - where set (BoundV tparams t) = BoundV tparams $ t `setUniqueness` Nonunique + where set (BoundV l tparams t) = BoundV l tparams $ t `setUniqueness` Nonunique set (OverloadedF ts pts rt) = OverloadedF ts pts rt set EqualityF = EqualityF set OpaqueF = OpaqueF @@ -1835,7 +1908,8 @@ onlySelfAliasing :: TermTypeM a -> TermTypeM a onlySelfAliasing = local (\scope -> scope { scopeVtable = M.mapWithKey set $ scopeVtable scope}) - where set k (BoundV tparams t) = BoundV tparams $ t `addAliases` S.intersection (S.singleton k) + where set k (BoundV l tparams t) = BoundV l tparams $ + t `addAliases` S.intersection (S.singleton (AliasBound k)) set _ (OverloadedF ts pts rt) = OverloadedF ts pts rt set _ EqualityF = EqualityF set _ OpaqueF = OpaqueF 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 @@ -10,6 +10,9 @@ , checkForDuplicateNames , checkTypeParams + , typeExpUses + , checkShapeParamUses + , TypeSub(..) , TypeSubs , substituteTypes @@ -24,6 +27,7 @@ import Control.Monad.Reader import Control.Monad.Except import Control.Monad.State +import Data.Bifunctor import Data.List import Data.Loc import Data.Maybe @@ -49,9 +53,9 @@ targs3 <- zipWithM (unifyTypeArgs uf) targs1 targs2 Just $ TypeVar (als1 <> als2) u3 t1 targs3 | otherwise = Nothing -unifyTypesU uf (Array et1 shape1 u1) (Array et2 shape2 u2) = - Array <$> unifyArrayElemTypes uf et1 et2 <*> - unifyShapes shape1 shape2 <*> uf u1 u2 +unifyTypesU uf (Array als1 u1 et1 shape1) (Array als2 u2 et2 shape2) = + Array (als1 <> als2) <$> uf u1 u2 + <*> unifyArrayElemTypes uf et1 et2 <*> unifyShapes shape1 shape2 unifyTypesU uf (Record ts1) (Record ts2) | length ts1 == length ts2, sort (M.keys ts1) == sort (M.keys ts2) = @@ -63,9 +67,9 @@ | e1 == e2 = Just e1 unifyTypesU _ _ _ = Nothing -unifyTypeArgs :: (Monoid als, Eq als, ArrayDim dim) => +unifyTypeArgs :: (ArrayDim dim) => (Uniqueness -> Uniqueness -> Maybe Uniqueness) - -> TypeArg dim als -> TypeArg dim als -> Maybe (TypeArg dim als) + -> TypeArg dim -> TypeArg dim -> Maybe (TypeArg dim) unifyTypeArgs _ (TypeArgDim d1 loc) (TypeArgDim d2 _) = TypeArgDim <$> unifyDims d1 d2 <*> pure loc unifyTypeArgs uf (TypeArgType t1 loc) (TypeArgType t2 _) = @@ -73,37 +77,36 @@ unifyTypeArgs _ _ _ = Nothing -unifyArrayElemTypes :: (Monoid als, Eq als, ArrayDim dim) => +unifyArrayElemTypes :: (ArrayDim dim) => (Uniqueness -> Uniqueness -> Maybe Uniqueness) - -> ArrayElemTypeBase dim als - -> ArrayElemTypeBase dim als - -> Maybe (ArrayElemTypeBase dim als) -unifyArrayElemTypes _ (ArrayPrimElem bt1 als1) (ArrayPrimElem bt2 als2) + -> ArrayElemTypeBase dim + -> ArrayElemTypeBase dim + -> Maybe (ArrayElemTypeBase dim) +unifyArrayElemTypes _ (ArrayPrimElem bt1) (ArrayPrimElem bt2) | bt1 == bt2 = - Just $ ArrayPrimElem bt1 (als1 <> als2) -unifyArrayElemTypes _ (ArrayPolyElem bt1 targs1 als1) (ArrayPolyElem bt2 targs2 als2) + Just $ ArrayPrimElem bt1 +unifyArrayElemTypes _ (ArrayPolyElem bt1 targs1) (ArrayPolyElem bt2 targs2) | bt1 == bt2, targs1 == targs2 = - Just $ ArrayPolyElem bt1 targs1 (als1 <> als2) + Just $ ArrayPolyElem bt1 targs1 unifyArrayElemTypes uf (ArrayRecordElem et1) (ArrayRecordElem et2) | sort (M.keys et1) == sort (M.keys et2) = ArrayRecordElem <$> traverse (uncurry $ unifyRecordArrayElemTypes uf) (M.intersectionWith (,) et1 et2) -unifyArrayElemTypes _ (ArrayEnumElem cs1 als1) (ArrayEnumElem cs2 als2) +unifyArrayElemTypes _ (ArrayEnumElem cs1) (ArrayEnumElem cs2) | cs1 == cs2 = - Just $ ArrayEnumElem cs1 (als1 <> als2) + Just $ ArrayEnumElem cs1 unifyArrayElemTypes _ _ _ = Nothing -unifyRecordArrayElemTypes :: (Monoid als, Eq als, ArrayDim dim) => +unifyRecordArrayElemTypes :: (ArrayDim dim) => (Uniqueness -> Uniqueness -> Maybe Uniqueness) - -> RecordArrayElemTypeBase dim als - -> RecordArrayElemTypeBase dim als - -> Maybe (RecordArrayElemTypeBase dim als) + -> RecordArrayElemTypeBase dim + -> RecordArrayElemTypeBase dim + -> Maybe (RecordArrayElemTypeBase dim) unifyRecordArrayElemTypes uf (RecordArrayElem et1) (RecordArrayElem et2) = RecordArrayElem <$> unifyArrayElemTypes uf et1 et2 -unifyRecordArrayElemTypes uf (RecordArrayArrayElem et1 shape1 u1) (RecordArrayArrayElem et2 shape2 u2) = - RecordArrayArrayElem <$> unifyArrayElemTypes uf et1 et2 <*> - unifyShapes shape1 shape2 <*> uf u1 u2 +unifyRecordArrayElemTypes uf (RecordArrayArrayElem et1 shape1) (RecordArrayArrayElem et2 shape2) = + RecordArrayArrayElem <$> unifyArrayElemTypes uf et1 et2 <*> unifyShapes shape1 shape2 unifyRecordArrayElemTypes _ _ _ = Nothing @@ -119,17 +122,20 @@ subuniqueOf Nonunique Unique = False subuniqueOf _ _ = True -data Bindage = BoundAsVar | UsedFree - deriving (Show, Eq) - checkTypeDecl :: MonadTypeChecker m => - TypeDeclBase NoInfo Name + [TypeParam] + -> TypeDeclBase NoInfo Name -> m (TypeDeclBase Info VName, Liftedness) -checkTypeDecl (TypeDecl t NoInfo) = do +checkTypeDecl tps (TypeDecl t NoInfo) = do checkForDuplicateNamesInType t (t', st, l) <- checkTypeExp t + checkShapeParamUses typeExpUses tps $ unfoldTypeExp t' return (TypeDecl t' $ Info st, l) +unfoldTypeExp :: TypeExp VName -> [TypeExp VName] +unfoldTypeExp (TEArrow _ t1 t2 _) = t1 : unfoldTypeExp t2 +unfoldTypeExp t = [t] + checkTypeExp :: MonadTypeChecker m => TypeExp Name -> m (TypeExp VName, StructType, Liftedness) @@ -292,6 +298,32 @@ pats TEVar{} = [] pats TEEnum{} = [] +-- | Ensure that every shape parameter is used in positive position at +-- least once before being used in negative position. +checkShapeParamUses :: (MonadTypeChecker m, Located a) => + (a -> ([VName], [VName])) -> [TypeParam] -> [a] + -> m () +checkShapeParamUses getUses tps ps = do + pos_uses <- foldM checkShapePositions [] ps + mapM_ (checkUsed pos_uses) tps + where tp_names = map typeParamName tps + + checkShapePositions pos_uses p = do + let (pos, neg) = getUses p + pos_uses' = pos <> pos_uses + forM_ neg $ \pv -> + unless ((pv `notElem` tp_names) || (pv `elem` pos_uses')) $ + throwError $ TypeError (srclocOf p) $ "Shape parameter `" ++ + pretty (baseName pv) ++ "` must first be given in " ++ + "a positive position (non-functional parameter)." + return pos_uses' + checkUsed uses (TypeParamDim pv loc) + | pv `elem` uses = return () + | otherwise = + throwError $ TypeError loc $ "Size parameter `" ++ + pretty (baseName pv) ++ "` unused." + checkUsed _ _ = return () + checkTypeParams :: MonadTypeChecker m => [TypeParamBase Name] -> ([TypeParamBase VName] -> m a) @@ -317,6 +349,26 @@ checkTypeParam (TypeParamType l pv loc) = TypeParamType l <$> checkParamName Type pv loc <*> pure loc +-- | Return the shapes used in a given type expression in positive and negative +-- position, respectively. +typeExpUses :: TypeExp VName -> ([VName], [VName]) +typeExpUses (TEVar _ _) = mempty +typeExpUses (TETuple tes _) = foldMap typeExpUses tes +typeExpUses (TERecord fs _) = foldMap (typeExpUses . snd) fs +typeExpUses (TEArray te d _) = typeExpUses te <> dimDeclUses d +typeExpUses (TEUnique te _) = typeExpUses te +typeExpUses (TEApply te targ _) = typeExpUses te <> typeArgUses targ + where typeArgUses (TypeArgExpDim d _) = dimDeclUses d + typeArgUses (TypeArgExpType tae) = typeExpUses tae +typeExpUses (TEArrow _ t1 t2 _) = + let (pos, neg) = typeExpUses t1 <> typeExpUses t2 + in (mempty, pos <> neg) +typeExpUses TEEnum{} = mempty + +dimDeclUses :: DimDecl VName -> ([VName], [VName]) +dimDeclUses (NamedDim v) = ([qualLeaf v], []) +dimDeclUses _ = mempty + data TypeSub = TypeSub TypeBinding | DimSub (DimDecl VName) deriving (Show) @@ -325,8 +377,9 @@ substituteTypes :: TypeSubs -> StructType -> StructType substituteTypes substs ot = case ot of - Array at shape u -> - fromMaybe nope $ arrayOf (substituteTypesInArrayElem at) (substituteInShape shape) u + Array als u at shape -> + maybe nope (`addAliases` (<>als)) $ + arrayOf (substituteTypesInArrayElem at) (substituteInShape shape) u Prim t -> Prim t TypeVar () u v targs | Just (TypeSub (TypeAbbr _ ps t)) <- @@ -341,9 +394,9 @@ Enum cs -> Enum cs where nope = error "substituteTypes: Cannot create array after substitution." - substituteTypesInArrayElem (ArrayPrimElem t ()) = + substituteTypesInArrayElem (ArrayPrimElem t) = Prim t - substituteTypesInArrayElem (ArrayPolyElem v targs ()) + substituteTypesInArrayElem (ArrayPolyElem v targs) | Just (TypeSub (TypeAbbr _ ps t)) <- M.lookup (qualLeaf (qualNameFromTypeName v)) substs = applyType ps t (map substituteInTypeArg targs) @@ -351,9 +404,8 @@ TypeVar () Nonunique v (map substituteInTypeArg targs) substituteTypesInArrayElem (ArrayRecordElem ts) = Record ts' - where ts' = fmap (substituteTypes substs . - fst . recordArrayElemToType) ts - substituteTypesInArrayElem (ArrayEnumElem cs ()) = + where ts' = fmap (substituteTypes substs . recordArrayElemToType) ts + substituteTypesInArrayElem (ArrayEnumElem cs) = Enum cs substituteInTypeArg (TypeArgDim d loc) = @@ -406,13 +458,13 @@ instance Substitutable (TypeBase () ()) where applySubst = substTypesAny -instance Substitutable (TypeBase () Names) where +instance Substitutable (TypeBase () Aliasing) where applySubst = substTypesAny . (fmap (fmap fromStruct).) instance Substitutable (TypeBase (DimDecl VName) ()) where applySubst = substTypesAny . (fmap (fmap vacuousShapeAnnotations).) -instance Substitutable (TypeBase (DimDecl VName) Names) where +instance Substitutable (TypeBase (DimDecl VName) Aliasing) where applySubst = substTypesAny . (fmap (fmap (vacuousShapeAnnotations . fromStruct)).) -- | Perform substitutions, from type names to types, on a type. Works @@ -422,13 +474,14 @@ -> TypeBase dim as -> TypeBase dim as substTypesAny lookupSubst ot = case ot of Prim t -> Prim t - Array et shape u -> fromMaybe nope $ - uncurry arrayOfWithAliases (subsArrayElem et) shape u + Array als u et shape -> + maybe nope (`addAliases` (<>als)) $ + arrayOf (subsArrayElem et) shape u -- We only substitute for a type variable with no arguments, since -- type parameters cannot have higher kind. TypeVar als u v targs -> case lookupSubst $ qualLeaf (qualNameFromTypeName v) of - Just (Subst t) -> t `setUniqueness` u + Just (Subst t) -> t `setUniqueness` u `addAliases` (<>als) Just PrimSubst -> TypeVar mempty u v $ map subsTypeArg targs Nothing -> TypeVar als u v $ map subsTypeArg targs Record ts -> Record $ fmap (substTypesAny lookupSubst) ts @@ -438,19 +491,19 @@ where nope = error "substTypesAny: Cannot create array after substitution." - subsArrayElem (ArrayPrimElem t as) = (Prim t, as) - subsArrayElem (ArrayPolyElem v targs as) = + subsArrayElem (ArrayPrimElem t) = Prim t + subsArrayElem (ArrayPolyElem v targs) = case lookupSubst $ qualLeaf $ qualNameFromTypeName v of - Just (Subst t) -> (t, as) + Just (Subst t) -> t -- It is intentional that we do not handle PrimSubst -- specially here, as we are inside an array, and that -- gives the aliasing. - _ -> (TypeVar as Nonunique v (map subsTypeArg targs), as) + _ -> TypeVar mempty Nonunique v $ map subsTypeArg targs subsArrayElem (ArrayRecordElem ts) = - let ts' = fmap recordArrayElemToType ts - in (Record $ fmap (substTypesAny lookupSubst . fst) ts', foldMap snd ts') - subsArrayElem (ArrayEnumElem cs as) = (Enum cs, as) + Record $ substTypesAny lookupSubst . recordArrayElemToType <$> ts + subsArrayElem (ArrayEnumElem cs) = Enum cs subsTypeArg (TypeArgType t loc) = - TypeArgType (substTypesAny lookupSubst t) loc + TypeArgType (substTypesAny lookupSubst' t) loc + where lookupSubst' = fmap (fmap $ bimap id (const ())) . lookupSubst subsTypeArg t = t diff --git a/src/Language/Futhark/Warnings.hs b/src/Language/Futhark/Warnings.hs --- a/src/Language/Futhark/Warnings.hs +++ b/src/Language/Futhark/Warnings.hs @@ -6,7 +6,6 @@ import Data.Monoid import Data.List import Data.Loc -import qualified Data.Semigroup as Sem import Prelude @@ -16,12 +15,11 @@ -- produces a human-readable description. newtype Warnings = Warnings [(SrcLoc, String)] deriving (Eq) -instance Sem.Semigroup Warnings where +instance Semigroup Warnings where Warnings ws1 <> Warnings ws2 = Warnings $ ws1 <> ws2 instance Monoid Warnings where mempty = Warnings mempty - mappend = (Sem.<>) instance Show Warnings where show (Warnings []) = "" diff --git a/src/futhark-bench.hs b/src/futhark-bench.hs deleted file mode 100644 --- a/src/futhark-bench.hs +++ /dev/null @@ -1,396 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} --- | Simple tool for benchmarking Futhark programs. Use the @--json@ --- flag for machine-readable output. -module Main (main) where - -import Control.Concurrent -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.Semigroup ((<>)) -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.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.Test -import Futhark.Util.Options - -data BenchOptions = BenchOptions - { optCompiler :: String - , optRunner :: String - , optRuns :: Int - , optExtraOptions :: [String] - , optJSON :: Maybe FilePath - , optTimeout :: Int - , optSkipCompilation :: Bool - , optExcludeCase :: [String] - , optIgnoreFiles :: [Regex] - } - -initialBenchOptions :: BenchOptions -initialBenchOptions = BenchOptions "futhark-c" "" 10 [] Nothing (-1) False - ["nobench", "disable"] [] - --- | 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) - -fork :: (a -> IO b) -> a -> IO (MVar b) -fork f x = do cell <- newEmptyMVar - void $ forkIO $ do result <- f x - putMVar cell result - return cell - -pmapIO :: (a -> IO b) -> [a] -> IO [b] -pmapIO f elems = go elems [] - where - go [] res = return res - go xs res = do - numThreads <- getNumCapabilities - let (e,es) = splitAt numThreads xs - mvars <- mapM (fork f) e - result <- mapM takeMVar mvars - go es (result ++ res) - -runBenchmarks :: BenchOptions -> [FilePath] -> IO () -runBenchmarks opts paths = do - -- We force line buffering to ensure that we produce running output. - -- Otherwise, CI tools and the like may believe we are hung and kill - -- us. - hSetBuffering stdout LineBuffering - benchmarks <- filter (not . ignored . fst) <$> testSpecsFromPaths paths - (skipped_benchmarks, compiled_benchmarks) <- - partitionEithers <$> pmapIO (compileBenchmark opts) benchmarks - - when (anyFailedToCompile skipped_benchmarks) exitFailure - - results <- concat <$> mapM (runBenchmark opts) compiled_benchmarks - case optJSON opts of - Nothing -> return () - Just file -> LBS.writeFile file $ encodeBenchResults results - when (anyFailed results) exitFailure - - where ignored f = any (`match` f) $ optIgnoreFiles opts - -anyFailed :: [BenchResult] -> Bool -anyFailed = any failedBenchResult - where failedBenchResult (BenchResult _ xs) = - any failedResult xs - failedResult (DataResult _ Left{}) = True - failedResult _ = False - -anyFailedToCompile :: [SkipReason] -> Bool -anyFailedToCompile = elem FailedToCompile - -data SkipReason = Skipped | FailedToCompile - deriving (Eq) - -compileBenchmark :: BenchOptions -> (FilePath, ProgramTest) - -> IO (Either SkipReason (FilePath, [InputOutputs])) -compileBenchmark opts (program, spec) = - case testAction spec of - RunCases cases _ _ | "nobench" `notElem` testTags spec, - "disable" `notElem` testTags spec, - any hasRuns cases -> - if optSkipCompilation opts - then do - exists <- doesFileExist $ binaryName program - if exists - then return $ Right (program, cases) - else do putStrLn $ binaryName program ++ " does not exist, but --skip-compilation passed." - return $ Left FailedToCompile - else do - putStr $ "Compiling " ++ program ++ "...\n" - (futcode, _, futerr) <- liftIO $ readProcessWithExitCode compiler - [program, "-o", binaryName program] "" - - case futcode of - ExitSuccess -> return $ Right (program, cases) - ExitFailure 127 -> do putStrLn $ "Failed:\n" ++ progNotFound compiler - return $ Left FailedToCompile - ExitFailure _ -> do putStrLn "Failed:\n" - SBS.putStrLn futerr - return $ Left FailedToCompile - _ -> - return $ Left Skipped - where compiler = optCompiler opts - - hasRuns (InputOutputs _ runs) = not $ null runs - -runBenchmark :: BenchOptions -> (FilePath, [InputOutputs]) -> IO [BenchResult] -runBenchmark opts (program, cases) = mapM forInputOutputs cases - where forInputOutputs (InputOutputs entry_name runs) = do - putStr $ "Results for " ++ program' ++ ":\n" - BenchResult program' . catMaybes <$> - mapM (runBenchmarkCase opts program entry_name pad_to) runs - where program' = if entry_name == "main" - then program - else program ++ ":" ++ T.unpack entry_name - - pad_to = foldl max 0 $ concatMap (map (length . runDescription) . iosTestRuns) cases - -reportResult :: [RunResult] -> IO () -reportResult [] = - print (0::Int) -reportResult results = do - let runtimes = map (fromIntegral . runMicroseconds) results - avg = sum runtimes / fromIntegral (length runtimes) - rel_dev = stddevp runtimes / mean runtimes :: Double - 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 - -runBenchmarkCase :: BenchOptions -> FilePath -> T.Text -> Int -> TestRun - -> IO (Maybe DataResult) -runBenchmarkCase _ _ _ _ (TestRun _ _ RunTimeFailure{} _ _) = - return Nothing -- Not our concern, we are not a testing tool. -runBenchmarkCase opts _ _ _ (TestRun tags _ _ _ _) - | any (`elem` tags) $ optExcludeCase opts = - return Nothing -runBenchmarkCase opts program entry pad_to (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 vs = do - vs' <- getValues dir vs - bs <- getValuesBS dir vs - return (LBS.toStrict bs, vs') - 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"] - - -- 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 compareValues 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 () - -commandLineOptions :: [FunOptDescr BenchOptions] -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 [] ["compiler"] - (ReqArg (\prog -> - Right $ \config -> config { optCompiler = prog }) - "PROGRAM") - "The compiler used (defaults to 'futhark-c')." - , Option [] ["runner"] - (ReqArg (\prog -> Right $ \config -> config { optRunner = prog }) "PROGRAM") - "The program used to run the Futhark-generated programs (defaults to nothing)." - , Option "p" ["pass-option"] - (ReqArg (\opt -> - Right $ \config -> - config { optExtraOptions = opt : optExtraOptions config }) - "OPT") - "Pass this option to programs being run." - , Option [] ["json"] - (ReqArg (\file -> - Right $ \config -> config { optJSON = Just file}) - "FILE") - "Scatter results in JSON format here." - , Option [] ["timeout"] - (ReqArg (\n -> - case reads n of - [(n', "")] - | n' < max_timeout -> - Right $ \config -> config { optTimeout = fromIntegral n' } - _ -> - Left $ error $ "'" ++ n ++ - "' is not an integer smaller than" ++ show max_timeout ++ ".") - "SECONDS") - "Number of seconds before a dataset is aborted." - , Option [] ["skip-compilation"] - (NoArg $ Right $ \config -> config { optSkipCompilation = True }) - "Use already compiled program." - , Option [] ["exclude-case"] - (ReqArg (\s -> Right $ \config -> - config { optExcludeCase = s : optExcludeCase config }) - "TAG") - "Do not run test cases with this tag." - , Option [] ["ignore-files"] - (ReqArg (\s -> Right $ \config -> - config { optIgnoreFiles = makeRegex s : optIgnoreFiles config }) - "REGEX") - "Ignore files matching this regular expression." - ] - where max_timeout :: Int - max_timeout = maxBound `div` 1000000 - -main :: IO () -main = mainWithOptions initialBenchOptions commandLineOptions "options... programs..." $ \progs config -> - Just $ runBenchmarks config progs - ---- The following extracted from hstats package by Marshall Beddoe: ---- https://hackage.haskell.org/package/hstats-0.3 - --- | Numerically stable mean -mean :: Floating a => [a] -> a -mean x = fst $ foldl' (\(!m, !n) x' -> (m+(x'-m)/(n+1),n+1)) (0,0) x - --- | Standard deviation of population -stddevp :: (Floating a) => [a] -> a -stddevp xs = sqrt $ pvar xs - --- | Population variance -pvar :: (Floating a) => [a] -> a -pvar xs = centralMoment xs (2::Int) - --- | Central moments -centralMoment :: (Floating b, Integral t) => [b] -> t -> b -centralMoment _ 1 = 0 -centralMoment xs r = sum (map (\x -> (x-m)^r) xs) / n - where - m = mean xs - n = fromIntegral $ length xs diff --git a/src/futhark-c.hs b/src/futhark-c.hs deleted file mode 100644 --- a/src/futhark-c.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main (main) where - -import Control.Monad.IO.Class -import System.FilePath -import System.Exit - -import Futhark.Pipeline -import Futhark.Passes -import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC -import Futhark.Util.Pretty (prettyText) -import Futhark.Compiler.CLI -import Futhark.Util - -main :: IO () -main = compilerMain () [] - "Compile sequential C" "Generate sequential C code from optimised Futhark program." - sequentialCpuPipeline $ \() mode outpath prog -> do - cprog <- either (`internalError` prettyText prog) return =<< - SequentialC.compileProg prog - let cpath = outpath `addExtension` "c" - hpath = outpath `addExtension` "h" - - case mode of - ToLibrary -> do - let (header, impl) = SequentialC.asLibrary cprog - liftIO $ writeFile hpath header - liftIO $ writeFile cpath impl - ToExecutable -> do - liftIO $ writeFile cpath $ SequentialC.asExecutable cprog - ret <- liftIO $ runProgramWithExitCode "gcc" - [cpath, "-O3", "-std=c99", "-lm", "-o", outpath] "" - case ret of - Left err -> - externalErrorS $ "Failed to run gcc: " ++ show err - Right (ExitFailure code, _, gccerr) -> - externalErrorS $ "gcc failed with code " ++ - show code ++ ":\n" ++ gccerr - Right (ExitSuccess, _, _) -> - return () diff --git a/src/futhark-cs.hs b/src/futhark-cs.hs deleted file mode 100644 --- a/src/futhark-cs.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main (main) where - -import Control.Monad.IO.Class -import Data.Maybe (fromMaybe) -import System.FilePath -import System.Directory -import System.Exit -import System.Environment - -import Futhark.Pipeline -import Futhark.Passes -import qualified Futhark.CodeGen.Backends.SequentialCSharp as SequentialCS -import Futhark.Util.Pretty (prettyText) -import Futhark.Compiler.CLI -import Futhark.Util - -main :: IO () -main = compilerMain () [] - "Compile sequential C#" "Generate sequential C# code from optimised Futhark program." - sequentialCpuPipeline $ \() mode outpath prog -> do - mono_libs <- liftIO $ fromMaybe "." <$> lookupEnv "MONO_PATH" - let class_name = - case mode of ToLibrary -> Just $ takeBaseName outpath - ToExecutable -> Nothing - csprog <- either (`internalError` prettyText prog) return =<< - SequentialCS.compileProg class_name prog - - let cspath = outpath `addExtension` "cs" - liftIO $ writeFile cspath csprog - - case mode of - ToLibrary -> return () - ToExecutable -> do - ret <- liftIO $ runProgramWithExitCode "csc" - ["-out:" ++ outpath - , "-lib:"++mono_libs - , "-r:Cloo.clSharp.dll" - , "-r:Mono.Options.dll" - , cspath - , "/unsafe"] "" - case ret of - Left err -> - externalErrorS $ "Failed to run csc: " ++ show err - Right (ExitFailure code, cscwarn, cscerr) -> - externalErrorS $ "csc failed with code " ++ show code ++ ":\n" ++ cscerr ++ cscwarn - Right (ExitSuccess, _, _) -> liftIO $ do - perms <- liftIO $ getPermissions outpath - setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/futhark-csopencl.hs b/src/futhark-csopencl.hs deleted file mode 100644 --- a/src/futhark-csopencl.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main (main) where - -import Control.Monad.IO.Class -import Data.Maybe (fromMaybe) -import System.Directory -import System.Environment -import System.Exit -import System.FilePath - -import Futhark.Pipeline -import Futhark.Passes -import qualified Futhark.CodeGen.Backends.CSOpenCL as CSOpenCL -import Futhark.Util.Pretty (prettyText) -import Futhark.Compiler.CLI -import Futhark.Util - -main :: IO () -main = compilerMain () [] - "Compile OpenCL C#" "Generate OpenCL C# code from optimised Futhark program." - gpuPipeline $ \() mode outpath prog -> do - mono_libs <- liftIO $ fromMaybe "." <$> lookupEnv "MONO_PATH" - - let class_name = - case mode of ToLibrary -> Just $ takeBaseName outpath - ToExecutable -> Nothing - csprog <- either (`internalError` prettyText prog) return =<< - CSOpenCL.compileProg class_name prog - - let cspath = outpath `addExtension` "cs" - liftIO $ writeFile cspath csprog - - case mode of - ToLibrary -> return () - ToExecutable -> do - ret <- liftIO $ runProgramWithExitCode "csc" - ["-out:" ++ outpath, "-lib:"++mono_libs, "-r:Cloo.clSharp.dll,Mono.Options.dll", cspath, "/unsafe"] "" - case ret of - Left err -> - externalErrorS $ "Failed to run csc: " ++ show err - Right (ExitFailure code, cscwarn, cscerr) -> - externalErrorS $ "csc failed with code " ++ show code ++ ":\n" ++ cscerr ++ cscwarn - Right (ExitSuccess, _, _) -> liftIO $ do - perms <- liftIO $ getPermissions outpath - setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/futhark-dataset.hs b/src/futhark-dataset.hs deleted file mode 100644 --- a/src/futhark-dataset.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Randomly generate Futhark input files containing values of a --- specified type and shape. -module Main (main) where - -import Control.Monad -import Control.Monad.ST -import qualified Data.Binary as Bin -import qualified Data.ByteString.Lazy.Char8 as BS -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Data.Word -import qualified Data.Vector.Unboxed.Mutable as UMVec -import qualified Data.Vector.Unboxed as UVec -import Data.Vector.Generic (freeze) - -import System.Console.GetOpt -import System.Random - -import Language.Futhark.Syntax hiding (Value, PrimValue(..), IntValue(..), FloatValue(..)) -import Language.Futhark.Attributes (UncheckedTypeExp, namesToPrimTypes) -import Language.Futhark.Parser -import Language.Futhark.Pretty () - -import Futhark.Test.Values -import Futhark.Util.Options - -main :: IO () -main = mainWithOptions initialDataOptions commandLineOptions "options..." f - where f [] config - | null $ optOrders config = Just $ do - maybe_vs <- readValues <$> BS.getContents - case maybe_vs of - Nothing -> error "Malformed data on standard input." - Just vs -> - case format config of - Text -> mapM_ (putStrLn . pretty) vs - Binary -> mapM_ (BS.putStr . Bin.encode) vs - Type -> mapM_ (putStrLn . pretty . valueType) vs - | otherwise = - Just $ zipWithM_ ($) (optOrders config) $ map mkStdGen [optSeed config..] - f _ _ = - Nothing - -data OutputFormat = Text - | Binary - | Type - deriving (Eq, Ord, Show) - -data DataOptions = DataOptions - { optSeed :: Int - , optRange :: RandomConfiguration - , optOrders :: [StdGen -> IO ()] - , format :: OutputFormat - } - -initialDataOptions :: DataOptions -initialDataOptions = DataOptions 0 initialRandomConfiguration [] Text - -commandLineOptions :: [FunOptDescr DataOptions] -commandLineOptions = [ - Option "s" ["seed"] - (ReqArg (\n -> - case reads n of - [(n', "")] -> - Right $ \config -> config { optSeed = n' } - _ -> - Left $ error $ "'" ++ n ++ "' is not an integer.") - "SEED") - "The seed to use when initialising the RNG." - , Option "g" ["generate"] - (ReqArg (\t -> - case tryMakeGenerator t of - Right g -> - Right $ \config -> - config { optOrders = - optOrders config ++ - [g (optRange config) (format config)] - } - Left err -> - Left $ error err) - "TYPE") - "Generate a random value of this type." - , Option [] ["text"] - (NoArg $ Right $ \opts -> opts { format = Text }) - "Output data in text format (must precede --generate)." - , Option "b" ["binary"] - (NoArg $ Right $ \opts -> opts { format = Binary }) - "Output data in binary Futhark format (must precede --generate)." - , Option "t" ["type"] - (NoArg $ Right $ \opts -> opts { format = Type }) - "Output the type (textually) rather than the value (must precede --generate)." - , setRangeOption "i8" seti8Range - , setRangeOption "i16" seti16Range - , setRangeOption "i32" seti32Range - , setRangeOption "i64" seti64Range - , setRangeOption "u8" setu8Range - , setRangeOption "u16" setu16Range - , setRangeOption "u32" setu32Range - , setRangeOption "u64" setu64Range - , setRangeOption "f32" setf32Range - , setRangeOption "f64" setf64Range - ] - -setRangeOption :: Read a => String - -> (Range a -> RandomConfiguration -> RandomConfiguration) - -> FunOptDescr DataOptions -setRangeOption tname set = - Option "" [name] - (ReqArg (\b -> - let (lower,rest) = span (/=':') b - upper = drop 1 rest - in case (reads lower, reads upper) of - ([(lower', "")], [(upper', "")]) -> - Right $ \config -> - config { optRange = set (lower', upper') $ optRange config } - _ -> - Left $ error $ "Invalid bounds: " ++ b - ) - "MIN:MAX") $ - "Range of " ++ tname ++ " values." - where name = tname ++ "-bounds" - -tryMakeGenerator :: String -> Either String (RandomConfiguration -> OutputFormat -> StdGen -> IO ()) -tryMakeGenerator t - | Just vs <- readValues $ BS.pack t = - return $ \_ fmt _ -> mapM_ (putValue fmt) vs - | otherwise = do - t' <- toValueType =<< either (Left . show) Right (parseType name (T.pack t)) - return $ \conf fmt stdgen -> do - let (v, _) = randomValue conf t' stdgen - putValue fmt v - where name = "option " ++ t - putValue Text = putStrLn . pretty - putValue Binary = BS.putStr . Bin.encode - putValue Type = putStrLn . pretty . valueType - -toValueType :: UncheckedTypeExp -> Either String ValueType -toValueType TETuple{} = Left "Cannot handle tuples yet." -toValueType TERecord{} = Left "Cannot handle records yet." -toValueType TEApply{} = Left "Cannot handle type applications yet." -toValueType TEArrow{} = Left "Cannot generate functions." -toValueType TEEnum{} = Left "Cannot handle enums yet." -toValueType (TEUnique t _) = toValueType t -toValueType (TEArray t d _) = do - d' <- constantDim d - ValueType ds t' <- toValueType t - return $ ValueType (d':ds) t' - where constantDim (ConstDim k) = Right k - constantDim _ = Left "Array has non-constant dimension declaration." -toValueType (TEVar (QualName [] v) _) - | Just t <- M.lookup v namesToPrimTypes = Right $ ValueType [] t -toValueType (TEVar v _) = - Left $ "Unknown type " ++ pretty v - --- | Closed interval, as in @System.Random@. -type Range a = (a, a) - -data RandomConfiguration = RandomConfiguration - { i8Range :: Range Int8 - , i16Range :: Range Int16 - , i32Range :: Range Int32 - , i64Range :: Range Int64 - , u8Range :: Range Word8 - , u16Range :: Range Word16 - , u32Range :: Range Word32 - , u64Range :: Range Word64 - , f32Range :: Range Float - , f64Range :: Range Double - } - --- The following lines provide evidence about how Haskells record --- system sucks. -seti8Range :: Range Int8 -> RandomConfiguration -> RandomConfiguration -seti8Range bounds config = config { i8Range = bounds } -seti16Range :: Range Int16 -> RandomConfiguration -> RandomConfiguration -seti16Range bounds config = config { i16Range = bounds } -seti32Range :: Range Int32 -> RandomConfiguration -> RandomConfiguration -seti32Range bounds config = config { i32Range = bounds } -seti64Range :: Range Int64 -> RandomConfiguration -> RandomConfiguration -seti64Range bounds config = config { i64Range = bounds } - -setu8Range :: Range Word8 -> RandomConfiguration -> RandomConfiguration -setu8Range bounds config = config { u8Range = bounds } -setu16Range :: Range Word16 -> RandomConfiguration -> RandomConfiguration -setu16Range bounds config = config { u16Range = bounds } -setu32Range :: Range Word32 -> RandomConfiguration -> RandomConfiguration -setu32Range bounds config = config { u32Range = bounds } -setu64Range :: Range Word64 -> RandomConfiguration -> RandomConfiguration -setu64Range bounds config = config { u64Range = bounds } - -setf32Range :: Range Float -> RandomConfiguration -> RandomConfiguration -setf32Range bounds config = config { f32Range = bounds } -setf64Range :: Range Double -> RandomConfiguration -> RandomConfiguration -setf64Range bounds config = config { f64Range = bounds } - -initialRandomConfiguration :: RandomConfiguration -initialRandomConfiguration = RandomConfiguration - (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) - (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) - (0.0, 1.0) (0.0, 1.0) - -randomValue :: RandomConfiguration -> ValueType -> StdGen -> (Value, StdGen) -randomValue conf (ValueType ds t) stdgen = - case t of - Signed Int8 -> gen i8Range Int8Value - Signed Int16 -> gen i16Range Int16Value - Signed Int32 -> gen i32Range Int32Value - Signed Int64 -> gen i64Range Int64Value - Unsigned Int8 -> gen u8Range Word8Value - Unsigned Int16 -> gen u16Range Word16Value - Unsigned Int32 -> gen u32Range Word32Value - Unsigned Int64 -> gen u64Range Word64Value - FloatType Float32 -> gen f32Range Float32Value - FloatType Float64 -> gen f64Range Float64Value - Bool -> gen (const (False,True)) BoolValue - where gen range final = randomVector (range conf) final ds stdgen - -randomVector :: (UMVec.Unbox v, Random v) => - Range v - -> (UVec.Vector Int -> UVec.Vector v -> Value) - -> [Int] -> StdGen - -> (Value, StdGen) -randomVector range final ds stdgen = runST $ do - -- USe some nice impure computation where we can preallocate a - -- vector of the desired size, populate it via the random number - -- generator, and then finally reutrn a frozen binary vector. - arr <- UMVec.new n - let fill stdgen' i - | i < n = do - let (v, stdgen'') = randomR range stdgen' - UMVec.write arr i v - fill stdgen'' $! i+1 - | otherwise = do - arr' <- final (UVec.fromList ds) <$> freeze arr - return (arr', stdgen') - fill stdgen 0 - where n = product ds diff --git a/src/futhark-doc.hs b/src/futhark-doc.hs deleted file mode 100644 --- a/src/futhark-doc.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Control.Monad.IO.Class (liftIO) -import Control.Monad.State -import Data.FileEmbed -import Data.List -import Data.Semigroup ((<>)) -import System.FilePath -import System.Directory (createDirectoryIfMissing) -import System.Console.GetOpt -import System.IO -import System.Exit -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T -import Text.Blaze.Html.Renderer.Text - -import Futhark.Doc.Generator -import Futhark.Compiler (readLibrary, dumpError, newFutharkConfig, Imports, fileProg) -import Futhark.Pipeline (runFutharkM, FutharkM, Verbosity(..)) -import Language.Futhark.Syntax (progDoc, DocComment(..)) -import Futhark.Util.Options -import Futhark.Util (directoryContents, trim) - -main :: IO () -main = mainWithOptions initialDocConfig commandLineOptions "options... -o outdir programs..." f - where f [dir] config = Just $ do - res <- runFutharkM (m config dir) Verbose - case res of - Left err -> liftIO $ do - dumpError newFutharkConfig err - exitWith $ ExitFailure 2 - Right () -> - return () - f _ _ = Nothing - - m :: DocConfig -> FilePath -> FutharkM () - m config dir = - case docOutput config of - Nothing -> liftIO $ do - hPutStrLn stderr "Must specify output directory with -o." - exitWith $ ExitFailure 1 - Just outdir -> do - files <- liftIO $ futFiles dir - when (docVerbose config) $ liftIO $ do - mapM_ (hPutStrLn stderr . ("Found source file "<>)) files - hPutStrLn stderr "Reading files..." - (_w, imports, _vns) <- readLibrary files - liftIO $ printDecs config outdir files $ nubBy sameImport imports - - sameImport (x, _) (y, _) = x == y - -futFiles :: FilePath -> IO [FilePath] -futFiles dir = filter isFut <$> directoryContents dir - where isFut = (==".fut") . takeExtension - -printDecs :: DocConfig -> FilePath -> [FilePath] -> Imports -> IO () -printDecs cfg dir files imports = do - let direct_imports = map (normalise . dropExtension) files - (file_htmls, _warnings) = renderFiles direct_imports $ - filter (not . ignored) imports - mapM_ (write . fmap renderHtml) file_htmls - write ("style.css", cssFile) - - where write :: (String, T.Text) -> IO () - write (name, content) = do let file = dir makeRelative "/" name - when (docVerbose cfg) $ - hPutStrLn stderr $ "Writing " <> file - createDirectoryIfMissing True $ takeDirectory file - T.writeFile file content - - -- Some files are not worth documenting; typically because - -- they contain tests. The current crude mechanism is to - -- recognise them by a file comment containing "ignore". - ignored (_, fm) = - case progDoc (fileProg fm) of - Just (DocComment s _) -> trim s == "ignore" - _ -> False - -cssFile :: T.Text -cssFile = $(embedStringFile "rts/futhark-doc/style.css") - -data DocConfig = DocConfig { docOutput :: Maybe FilePath - , docVerbose :: Bool - } - -initialDocConfig :: DocConfig -initialDocConfig = DocConfig { docOutput = Nothing - , docVerbose = False - } - -type DocOption = OptDescr (Either (IO ()) (DocConfig -> DocConfig)) - -commandLineOptions :: [DocOption] -commandLineOptions = [ Option "o" ["output-directory"] - (ReqArg (\dirname -> Right $ \config -> config { docOutput = Just dirname }) - "DIR") - "Directory in which to put generated documentation." - , Option "v" ["verbose"] - (NoArg $ Right $ \config -> config { docVerbose = True }) - "Print status messages on stderr." - ] diff --git a/src/futhark-opencl.hs b/src/futhark-opencl.hs deleted file mode 100644 --- a/src/futhark-opencl.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main (main) where - -import Control.Monad.IO.Class -import System.FilePath -import System.Exit -import qualified System.Info - -import Futhark.Pipeline -import Futhark.Passes -import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL -import Futhark.Util -import Futhark.Util.Pretty (prettyText) -import Futhark.Compiler.CLI - -main :: IO () -main = compilerMain () [] - "Compile OpenCL" "Generate OpenCL/C code from optimised Futhark program." - gpuPipeline $ \() mode outpath prog -> do - cprog <- either (`internalError` prettyText prog) return =<< - COpenCL.compileProg prog - let cpath = outpath `addExtension` "c" - hpath = outpath `addExtension` "h" - extra_options - | System.Info.os == "darwin" = - ["-framework", "OpenCL"] - | System.Info.os == "mingw32" = - ["-lOpenCL64"] - | otherwise = - ["-lOpenCL"] - - case mode of - ToLibrary -> do - let (header, impl) = COpenCL.asLibrary cprog - liftIO $ writeFile hpath header - liftIO $ writeFile cpath impl - ToExecutable -> do - liftIO $ writeFile cpath $ COpenCL.asExecutable cprog - ret <- liftIO $ runProgramWithExitCode "gcc" - ([cpath, "-O3", "-std=c99", "-lm", "-o", outpath] ++ extra_options) "" - case ret of - Left err -> - externalErrorS $ "Failed to run gcc: " ++ show err - Right (ExitFailure code, _, gccerr) -> - externalErrorS $ "gcc failed with code " ++ - show code ++ ":\n" ++ gccerr - Right (ExitSuccess, _, _) -> - return () diff --git a/src/futhark-pkg.hs b/src/futhark-pkg.hs deleted file mode 100644 --- a/src/futhark-pkg.hs +++ /dev/null @@ -1,387 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Main (main) where - -import Control.Monad.IO.Class -import Control.Monad.State -import Control.Monad.Reader -import Data.Maybe -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.ByteString.Lazy as LBS -import Data.List -import Data.Monoid -import System.Directory -import System.FilePath -import qualified System.FilePath.Posix as Posix -import System.Environment -import System.Exit -import System.IO -import System.Console.GetOpt - -import qualified Codec.Archive.Zip as Zip -import Network.HTTP.Client -import Network.HTTP.Client.TLS - -import Prelude - -import Futhark.Util.Options -import Futhark.Pkg.Types -import Futhark.Pkg.Info -import Futhark.Pkg.Solve -import Futhark.Util (directoryContents) -import Futhark.Util.Log - ---- Installing packages - -installInDir :: BuildList -> FilePath -> PkgM () -installInDir (BuildList bl) dir = do - let putEntry from_dir pdir entry - -- The archive may contain all kinds of other stuff that we don't want. - | not (isInPkgDir from_dir $ Zip.eRelativePath entry) - || hasTrailingPathSeparator (Zip.eRelativePath entry) = return () - | otherwise = do - -- Since we are writing to paths indicated in a zipfile we - -- downloaded from the wild Internet, we are going to be a - -- little bit paranoid. Specifically, we want to avoid - -- writing outside of the 'lib/' directory. We do this by - -- bailing out if the path contains any '..' components. We - -- have to use System.FilePath.Posix, because the zip library - -- claims to encode filepaths with '/' directory seperators no - -- matter the host OS. - when (".." `elem` Posix.splitPath (Zip.eRelativePath entry)) $ - fail $ "Zip archive for " <> pdir <> " contains suspicuous path: " <> - Zip.eRelativePath entry - let f = pdir makeRelative from_dir (Zip.eRelativePath entry) - createDirectoryIfMissing True $ takeDirectory f - LBS.writeFile f $ Zip.fromEntry entry - - isInPkgDir from_dir f = - Posix.splitPath from_dir `isPrefixOf` Posix.splitPath f - - forM_ (M.toList bl) $ \(p, v) -> do - info <- lookupPackageRev p v - a <- downloadZipball $ pkgRevZipballUrl info - m <- getManifest $ pkgRevGetManifest info - - -- Compute the directory in the zipball that should contain the - -- package files. - let noPkgDir = fail $ "futhark.pkg for " ++ T.unpack p ++ "-" ++ - T.unpack (prettySemVer v) ++ " does not define a package path." - from_dir <- maybe noPkgDir (return . (pkgRevZipballDir info <>)) $ pkgDir m - - -- The directory in the local file system that will contain the - -- package files. - let pdir = dir T.unpack p - -- Remove any existing directory for this package. This is a bit - -- inefficient, as the likelihood that the old ``lib`` directory - -- already contains the correct version is rather high. We should - -- have a way to recognise this situation, and not download the - -- zipball in that case. - liftIO $ removePathForcibly pdir - liftIO $ createDirectoryIfMissing True pdir - - liftIO $ mapM_ (putEntry from_dir pdir) $ Zip.zEntries a - -libDir, libNewDir, libOldDir :: FilePath -(libDir, libNewDir, libOldDir) = ("lib", "lib~new", "lib~old") - --- | Install the packages listed in the build list in the 'lib' --- directory of the current working directory. Since we are touching --- the file system, we are going to be very paranoid. In particular, --- we want to avoid corrupting the 'lib' directory if something fails --- along the way. --- --- The procedure is as follows: --- --- 1) Create a directory 'lib~new'. Delete an existing 'lib~new' if --- necessary. --- --- 2) Populate 'lib~new' based on the build list. --- --- 3) Rename 'lib' to 'lib~old'. Delete an existing 'lib~old' if --- necessary. --- --- 4) Rename 'lib~new' to 'lib' --- --- 5) If the current package has package path 'p', move 'lib~old/p' to --- 'lib~new/p'. --- --- 6) Delete 'lib~old'. --- --- Since POSIX at least guarantees atomic renames, the only place this --- can fail is between steps 3, 4, and 5. In that case, at least the --- 'lib~old' will still exist and can be put back by the user. -installBuildList :: Maybe PkgPath -> BuildList -> PkgM () -installBuildList p bl = do - libdir_exists <- liftIO $ doesDirectoryExist libDir - - -- 1 - liftIO $ do removePathForcibly libNewDir - createDirectoryIfMissing False libNewDir - - -- 2 - installInDir bl libNewDir - - -- 3 - when libdir_exists $ liftIO $ do - removePathForcibly libOldDir - renameDirectory libDir libOldDir - - -- 4 - liftIO $ renameDirectory libNewDir libDir - - -- 5 - case pkgPathFilePath <$> p of - Just pfp | libdir_exists -> liftIO $ do - pkgdir_exists <- doesDirectoryExist $ libOldDir pfp - when pkgdir_exists $ do - -- Ensure the parent directories exist so that we can move the - -- package directory directly. - createDirectoryIfMissing True $ takeDirectory $ libDir pfp - renameDirectory (libOldDir pfp) (libDir pfp) - _ -> return () - - -- 6 - when libdir_exists $ liftIO $ removePathForcibly libOldDir - -getPkgManifest :: PkgM PkgManifest -getPkgManifest = do - file_exists <- liftIO $ doesFileExist futharkPkg - dir_exists <- liftIO $ doesDirectoryExist futharkPkg - - case (file_exists, dir_exists) of - (True, _) -> liftIO $ parsePkgManifestFromFile futharkPkg - (_, True) -> fail $ futharkPkg <> - " exists, but it is a directory! What in Odin's beard..." - _ -> liftIO $ do T.putStrLn $ T.pack futharkPkg <> " not found - pretending it's empty." - return $ newPkgManifest Nothing - -putPkgManifest :: PkgManifest -> PkgM () -putPkgManifest = liftIO . T.writeFile futharkPkg . prettyPkgManifest - ---- The CLI - -newtype PkgConfig = PkgConfig { pkgVerbose :: Bool } - --- | The monad in which futhark-pkg runs. -newtype PkgM a = PkgM { unPkgM :: ReaderT PkgConfig (StateT (PkgRegistry PkgM) IO) a } - deriving (Functor, Applicative, MonadIO, MonadReader PkgConfig) - -instance Monad PkgM where - PkgM m >>= f = PkgM $ m >>= unPkgM . f - return = PkgM . return - fail s = liftIO $ do - prog <- getProgName - putStrLn $ prog ++ ": " ++ s - exitFailure - -instance MonadPkgRegistry PkgM where - putPkgRegistry = PkgM . put - getPkgRegistry = PkgM get - -instance MonadLogger PkgM where - addLog l = do - verbose <- asks pkgVerbose - when verbose $ liftIO $ T.hPutStr stderr $ toText l - -runPkgM :: PkgConfig -> PkgM a -> IO a -runPkgM cfg (PkgM m) = evalStateT (runReaderT m cfg) mempty - -cmdMain :: String -> ([String] -> PkgConfig -> Maybe (IO ())) -> IO () -cmdMain = mainWithOptions (PkgConfig False) options - where options = [ Option "v" ["verbose"] - (NoArg $ Right $ \cfg -> cfg { pkgVerbose = True }) - "Write running diagnostics to stderr."] - -doFmt :: IO () -doFmt = mainWithOptions () [] "fmt" $ \args () -> - case args of - [] -> Just $ do - m <- parsePkgManifestFromFile futharkPkg - T.writeFile futharkPkg $ prettyPkgManifest m - _ -> Nothing - -doCheck :: IO () -doCheck = cmdMain "check" $ \args cfg -> - case args of - [] -> Just $ runPkgM cfg $ do - m <- getPkgManifest - bl <- solveDeps $ pkgRevDeps m - - liftIO $ T.putStrLn "Dependencies chosen:" - liftIO $ T.putStr $ prettyBuildList bl - - case commented $ manifestPkgPath m of - Nothing -> return () - Just p -> do - let pdir = "lib" T.unpack p - - pdir_exists <- liftIO $ doesDirectoryExist pdir - - unless pdir_exists $ liftIO $ do - T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not exist." - exitFailure - - anything <- liftIO $ any ((==".fut") . takeExtension) <$> - directoryContents ("lib" T.unpack p) - unless anything $ liftIO $ do - T.putStrLn $ "Problem: the directory " <> T.pack pdir <> " does not contain any .fut files." - exitFailure - _ -> Nothing - -doSync :: IO () -doSync = cmdMain "sync" $ \args cfg -> - case args of - [] -> Just $ runPkgM cfg $ do - m <- getPkgManifest - bl <- solveDeps $ pkgRevDeps m - installBuildList (commented $ manifestPkgPath m) bl - _ -> Nothing - -doAdd :: IO () -doAdd = cmdMain "add PKGPATH" $ \args cfg -> - case args of - [p, v] | Right v' <- parseVersion $ T.pack v -> Just $ runPkgM cfg $ doAdd' (T.pack p) v' - [p] -> Just $ runPkgM cfg $ - -- Look up the newest revision of the package. - doAdd' (T.pack p) =<< lookupNewestRev (T.pack p) - _ -> Nothing - - where - doAdd' p v = do - m <- getPkgManifest - - -- See if this package (and its dependencies) even exists. We - -- do this by running the solver with the dependencies already - -- in the manifest, plus this new one. The Monoid instance for - -- PkgRevDeps is left-biased, so we are careful to use the new - -- version for this package. - _ <- solveDeps $ PkgRevDeps (M.singleton p (v, Nothing)) <> pkgRevDeps m - - -- We either replace any existing occurence of package 'p', or - -- we add a new one. - p_info <- lookupPackageRev p v - let hash = case (_svMajor v, _svMinor v, _svPatch v) of - -- We do not perform hash-pinning for - -- (0,0,0)-versions, because these already embed a - -- specific revision ID into their version number. - (0, 0, 0) -> Nothing - _ -> Just $ pkgRevCommit p_info - req = Required p v hash - (m', prev_r) = addRequiredToManifest req m - - case prev_r of - Just prev_r' - | requiredPkgRev prev_r' == v -> - liftIO $ T.putStrLn $ "Package already at version " <> prettySemVer v <> "; nothing to do." - | otherwise -> - liftIO $ T.putStrLn $ "Replaced " <> p <> " " <> - prettySemVer (requiredPkgRev prev_r') <> " => " <> prettySemVer v <> "." - Nothing -> - liftIO $ T.putStrLn $ "Added new required package " <> p <> " " <> prettySemVer v <> "." - putPkgManifest m' - liftIO $ T.putStrLn "Remember to run 'futhark-pkg sync'." - -doRemove :: IO () -doRemove = cmdMain "remove PKGPATH" $ \args cfg -> - case args of - [p] -> Just $ runPkgM cfg $ doRemove' $ T.pack p - _ -> Nothing - where - doRemove' p = do - m <- getPkgManifest - case removeRequiredFromManifest p m of - Nothing -> liftIO $ do - T.putStrLn $ "No package " <> p <> " found in " <> T.pack futharkPkg <> "." - exitFailure - Just (m', r) -> do - putPkgManifest m' - liftIO $ T.putStrLn $ "Removed " <> p <> " " <> prettySemVer (requiredPkgRev r) <> "." - -doInit :: IO () -doInit = cmdMain "create PKGPATH" $ \args cfg -> - case args of - [p] -> Just $ runPkgM cfg $ doCreate' $ T.pack p - _ -> Nothing - where - doCreate' p = do - exists <- liftIO $ (||) <$> doesFileExist futharkPkg <*> doesDirectoryExist futharkPkg - when exists $ liftIO $ do - T.putStrLn $ T.pack futharkPkg <> " already exists." - exitFailure - - liftIO $ createDirectoryIfMissing True $ "lib" T.unpack p - liftIO $ T.putStrLn $ "Created directory " <> T.pack ("lib" T.unpack p) <> "." - - putPkgManifest $ newPkgManifest $ Just p - liftIO $ T.putStrLn $ "Wrote " <> T.pack futharkPkg <> "." - -doUpgrade :: IO () -doUpgrade = cmdMain "upgrade" $ \args cfg -> - case args of - [] -> Just $ runPkgM cfg $ do - m <- getPkgManifest - rs <- traverse (mapM (traverse upgrade)) $ manifestRequire m - putPkgManifest m { manifestRequire = rs } - _ -> Nothing - where upgrade req = do - v <- lookupNewestRev $ requiredPkg req - h <- pkgRevCommit <$> lookupPackageRev (requiredPkg req) v - - when (v /= requiredPkgRev req) $ - liftIO $ T.putStrLn $ "Upgraded " <> requiredPkg req <> " " <> - prettySemVer (requiredPkgRev req) <> " => " <> prettySemVer v <> "." - - return req { requiredPkgRev = v - , requiredHash = Just h } - -doVersions :: IO () -doVersions = cmdMain "versions PKGPATH" $ \args cfg -> - case args of - [p] -> Just $ runPkgM cfg $ doVersions' $ T.pack p - _ -> Nothing - where doVersions' = - mapM_ (liftIO . T.putStrLn . prettySemVer) . M.keys . pkgVersions - <=< lookupPackage - -main :: IO () -main = do - -- Ensure that we can make HTTPS requests. - setGlobalManager =<< newManager tlsManagerSettings - - -- Avoid Git asking for credentials. We prefer failure. - liftIO $ setEnv "GIT_TERMINAL_PROMPT" "0" - - args <- getArgs - let commands = [ ("add", - (doAdd, "Add another required package to futhark.pkg.")) - , ("check", - (doCheck, "Check that futhark.pkg is satisfiable.")) - , ("init", - (doInit, "Create a new futhark.pkg and a lib/ skeleton.")) - , ("fmt", - (doFmt, "Reformat futhark.pkg.")) - , ("sync", - (doSync, "Populate lib/ as specified by futhark.pkg.")) - , ("remove", - (doRemove, "Remove a required package from futhark.pkg.")) - , ("upgrade", - (doUpgrade, "Upgrade all packages to newest versions.")) - , ("versions", - (doVersions, "List available versions for a package.")) - ] - usage = "options... <" <> intercalate "|" (map fst commands) <> ">" - case args of - cmd : args' | Just (m, _) <- lookup cmd commands -> withArgs args' m - _ -> mainWithOptions () [] usage $ \_ () -> Just $ do - let k = maximum (map (length . fst) commands) + 3 - usageMsg $ T.unlines $ - [" ...:", "", "Commands:"] ++ - [ " " <> T.pack cmd <> T.pack (replicate (k - length cmd) ' ') <> desc - | (cmd, (_, desc)) <- commands ] - - where usageMsg s = do - T.putStrLn $ "Usage: futhark-pkg [--version] [--help] " <> s - exitFailure diff --git a/src/futhark-py.hs b/src/futhark-py.hs deleted file mode 100644 --- a/src/futhark-py.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main (main) where - -import Control.Monad.IO.Class -import System.FilePath -import System.Directory - -import Futhark.Pipeline -import Futhark.Passes -import qualified Futhark.CodeGen.Backends.SequentialPython as SequentialPy -import Futhark.Util.Pretty (prettyText) -import Futhark.Compiler.CLI - -main :: IO () -main = compilerMain () [] - "Compile sequential Python" "Generate sequential Python code from optimised Futhark program." - sequentialCpuPipeline $ \() mode outpath prog -> do - let class_name = - case mode of ToLibrary -> Just $ takeBaseName outpath - ToExecutable -> Nothing - pyprog <- either (`internalError` prettyText prog) return =<< - SequentialPy.compileProg class_name prog - - case mode of - ToLibrary -> - liftIO $ writeFile (outpath `addExtension` "py") pyprog - ToExecutable -> liftIO $ do - writeFile outpath pyprog - perms <- liftIO $ getPermissions outpath - setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/futhark-pyopencl.hs b/src/futhark-pyopencl.hs deleted file mode 100644 --- a/src/futhark-pyopencl.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main (main) where - -import Control.Monad.IO.Class -import System.FilePath -import System.Directory - -import Futhark.Pipeline -import Futhark.Passes -import qualified Futhark.CodeGen.Backends.PyOpenCL as PyOpenCL -import Futhark.Util.Pretty (prettyText) -import Futhark.Compiler.CLI - -main :: IO () -main = compilerMain () [] - "Compile PyOpenCL" "Generate Python + OpenCL code from optimised Futhark program." - gpuPipeline $ \() mode outpath prog -> do - let class_name = - case mode of ToLibrary -> Just $ takeBaseName outpath - ToExecutable -> Nothing - pyprog <- either (`internalError` prettyText prog) return =<< - PyOpenCL.compileProg class_name prog - - case mode of - ToLibrary -> - liftIO $ writeFile (outpath `addExtension` "py") pyprog - ToExecutable -> liftIO $ do - writeFile outpath pyprog - perms <- liftIO $ getPermissions outpath - setPermissions outpath $ setOwnerExecutable True perms diff --git a/src/futhark-test.hs b/src/futhark-test.hs deleted file mode 100644 --- a/src/futhark-test.hs +++ /dev/null @@ -1,590 +0,0 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts, LambdaCase #-} --- | This program is a convenience utility for running the Futhark --- test suite, and its test programs. -module Main (main) where - -import Control.Applicative.Lift (runErrors, failure, Errors, Lift(..)) -import Control.Concurrent -import Control.Exception -import Control.Monad -import Control.Monad.Except hiding (throwError) -import qualified Control.Monad.Except as E -import qualified Data.ByteString as SBS -import qualified Data.ByteString.Lazy as LBS - -import Data.List -import Data.Semigroup ((<>)) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import System.Console.ANSI -import System.Process.ByteString (readProcessWithExitCode) -import System.Exit -import System.FilePath -import System.Console.GetOpt -import System.IO -import Text.Regex.TDFA - -import Futhark.Analysis.Metrics -import Futhark.Test -import Futhark.Util.Options -import Futhark.Util.Pretty (prettyText) -import Futhark.Util.Table - ---- Test execution - -type TestM = ExceptT [T.Text] IO - --- Taken from transformers-0.5.5.0. -eitherToErrors :: Either e a -> Errors e a -eitherToErrors = either failure Pure - -throwError :: MonadError [e] m => e -> m a -throwError e = E.throwError [e] - -runTestM :: TestM () -> IO TestResult -runTestM = fmap (either Failure $ const Success) . runExceptT - -io :: IO a -> TestM a -io = liftIO - -context :: T.Text -> TestM a -> TestM a -context s = withExceptT $ - \case - [] -> [] - (e:es') -> (s <> ":\n" <> e):es' - -accErrors :: [TestM a] -> TestM [a] -accErrors tests = do - eithers <- lift $ mapM runExceptT tests - let errors = traverse eitherToErrors eithers - ExceptT $ return $ runErrors errors - -accErrors_ :: [TestM a] -> TestM () -accErrors_ = void . accErrors - -data TestResult = Success - | Failure [T.Text] - deriving (Eq, Show) - -data TestCase = TestCase { _testCaseMode :: TestMode - , testCaseProgram :: FilePath - , testCaseTest :: ProgramTest - , _testCasePrograms :: ProgConfig - } - deriving (Show) - -instance Eq TestCase where - x == y = testCaseProgram x == testCaseProgram y - -instance Ord TestCase where - x `compare` y = testCaseProgram x `compare` testCaseProgram y - -data RunResult = ErrorResult Int SBS.ByteString - | SuccessResult [Value] - -progNotFound :: T.Text -> T.Text -progNotFound s = s <> ": command not found" - -optimisedProgramMetrics :: ProgConfig -> StructurePipeline -> FilePath -> TestM AstMetrics -optimisedProgramMetrics programs pipeline program = - case pipeline of SOACSPipeline -> - check "-s" - KernelsPipeline -> - check "--kernels" - SequentialCpuPipeline -> - check "--cpu" - GpuPipeline -> - check "--gpu" - where check opt = do - (code, output, err) <- - io $ readProcessWithExitCode (configTypeChecker programs) [opt, "--metrics", program] "" - let output' = T.decodeUtf8 output - case code of - ExitSuccess - | [(m, [])] <- reads $ T.unpack output' -> return m - | otherwise -> throwError $ "Could not read metrics output:\n" <> output' - ExitFailure 127 -> throwError $ progNotFound $ T.pack $ configTypeChecker programs - ExitFailure _ -> throwError $ T.decodeUtf8 err - -testMetrics :: ProgConfig -> FilePath -> StructureTest -> TestM () -testMetrics programs program (StructureTest pipeline (AstMetrics expected)) = - context "Checking metrics" $ do - actual <- optimisedProgramMetrics programs pipeline program - accErrors_ $ map (ok actual) $ M.toList expected - where ok (AstMetrics metrics) (name, expected_occurences) = - case M.lookup name metrics of - Nothing - | expected_occurences > 0 -> - throwError $ name <> " should have occurred " <> T.pack (show expected_occurences) <> - " times, but did not occur at all in optimised program." - Just actual_occurences - | expected_occurences /= actual_occurences -> - throwError $ name <> " should have occurred " <> T.pack (show expected_occurences) <> - " times, but occured " <> T.pack (show actual_occurences) <> " times." - _ -> return () - -testWarnings :: [WarningTest] -> SBS.ByteString -> TestM () -testWarnings warnings futerr = accErrors_ $ map testWarning warnings - where testWarning (ExpectedWarning regex_s regex) - | not (match regex $ T.unpack $ T.decodeUtf8 futerr) = - throwError $ "Expected warning:\n " <> regex_s <> - "\nGot warnings:\n " <> T.decodeUtf8 futerr - | otherwise = return () - -runTestCase :: TestCase -> TestM () -runTestCase (TestCase mode program testcase progs) = - case testAction testcase of - - CompileTimeFailure expected_error -> do - let typeChecker = configTypeChecker progs - context ("Type-checking with " <> T.pack typeChecker) $ do - (code, _, err) <- - io $ readProcessWithExitCode typeChecker ["-t", program] "" - case code of - ExitSuccess -> throwError "Expected failure\n" - ExitFailure 127 -> throwError $ progNotFound $ T.pack typeChecker - ExitFailure 1 -> throwError $ T.decodeUtf8 err - ExitFailure _ -> checkError expected_error err - - RunCases _ _ warnings | mode == TypeCheck -> do - let typeChecker = configTypeChecker progs - options = ["-t", program] ++ configExtraCompilerOptions progs - context ("Type-checking with " <> T.pack typeChecker) $ do - (code, _, err) <- io $ readProcessWithExitCode typeChecker options "" - testWarnings warnings err - case code of - ExitSuccess -> return () - ExitFailure 127 -> throwError $ progNotFound $ T.pack typeChecker - ExitFailure _ -> throwError $ T.decodeUtf8 err - - RunCases ios structures warnings -> do - -- Compile up-front and reuse same executable for several entry points. - let compiler = configCompiler progs - interpreter = configInterpreter progs - extra_options = configExtraCompilerOptions progs - unless (mode == Interpreted) $ - context ("Compiling with " <> T.pack compiler) $ do - compileTestProgram extra_options compiler program warnings - mapM_ (testMetrics progs program) structures - unless (mode == Compile) $ - context "Running compiled program" $ - accErrors_ $ map (runCompiledEntry program progs) ios - unless (mode == Compile || mode == Compiled) $ - context ("Interpreting with " <> T.pack interpreter) $ - accErrors_ $ map (runInterpretedEntry interpreter program) ios - -runInterpretedEntry :: String -> FilePath -> InputOutputs -> TestM() -runInterpretedEntry futharki program (InputOutputs entry run_cases) = - let dir = takeDirectory program - runInterpretedCase run@(TestRun _ inputValues expectedResult index _) = - unless ("compiled" `elem` runTags run) $ - context ("Entry point: " <> entry - <> "; dataset: " <> T.pack (runDescription run)) $ do - - input <- T.unlines . map prettyText <$> getValues dir inputValues - expectedResult' <- getExpectedResult dir expectedResult - (code, output, err) <- - io $ readProcessWithExitCode futharki ["-e", T.unpack entry, program] $ - T.encodeUtf8 input - case code of - ExitFailure 127 -> throwError $ progNotFound $ T.pack futharki - - _ -> compareResult entry index program expectedResult' - =<< runResult program code output err - - in accErrors_ $ map runInterpretedCase run_cases - -runCompiledEntry :: FilePath -> ProgConfig -> InputOutputs -> TestM () -runCompiledEntry program progs (InputOutputs entry run_cases) = - -- Explicitly prefixing the current directory is necessary for - -- readProcessWithExitCode to find the binary when binOutputf has - -- no path component. - let binOutputf = dropExtension program - dir = takeDirectory program - binpath = "." binOutputf - entry_options = ["-e", T.unpack entry] - - runner = configRunner progs - extra_options = configExtraOptions progs - (to_run, to_run_args) - | null runner = (binpath, entry_options ++ extra_options) - | otherwise = (runner, binpath : entry_options ++ extra_options) - - runCompiledCase run@(TestRun _ inputValues expectedResult index _) = - context ("Entry point: " <> entry - <> "; dataset: " <> T.pack (runDescription run)) $ do - - input <- getValuesBS dir inputValues - expectedResult' <- getExpectedResult dir expectedResult - (progCode, output, progerr) <- - io $ readProcessWithExitCode to_run to_run_args $ LBS.toStrict input - compareResult entry index program expectedResult' - =<< runResult program progCode output progerr - - in context ("Running " <> T.pack (unwords $ binpath : entry_options ++ extra_options)) $ - accErrors_ $ map runCompiledCase run_cases - -checkError :: ExpectedError -> SBS.ByteString -> TestM () -checkError (ThisError regex_s regex) err - | not (match regex $ T.unpack $ T.decodeUtf8 err) = - throwError $ "Expected error:\n " <> regex_s <> - "\nGot error:\n " <> T.decodeUtf8 err -checkError _ _ = - return () - -runResult :: FilePath -> ExitCode -> SBS.ByteString -> SBS.ByteString -> TestM RunResult -runResult program ExitSuccess stdout_s _ = - case valuesFromByteString "stdout" $ LBS.fromStrict stdout_s of - Left e -> do - let actualf = program `addExtension` "actual" - io $ SBS.writeFile actualf stdout_s - throwError $ T.pack e <> "\n(See " <> T.pack actualf <> ")" - Right vs -> return $ SuccessResult vs -runResult _ (ExitFailure code) _ stderr_s = - return $ ErrorResult code stderr_s - -getExpectedResult :: MonadIO m => - FilePath -> ExpectedResult Values - -> m (ExpectedResult [Value]) -getExpectedResult dir (Succeeds (Just vals)) = Succeeds . Just <$> getValues dir vals -getExpectedResult _ (Succeeds Nothing) = return $ Succeeds Nothing -getExpectedResult _ (RunTimeFailure err) = return $ RunTimeFailure err - -compileTestProgram :: [String] -> String -> FilePath -> [WarningTest] -> TestM () -compileTestProgram extra_options futharkc program warnings = do - (futcode, _, futerr) <- io $ readProcessWithExitCode futharkc options "" - testWarnings warnings futerr - case futcode of - ExitFailure 127 -> throwError $ progNotFound $ T.pack futharkc - ExitFailure _ -> throwError $ T.decodeUtf8 futerr - ExitSuccess -> return () - where binOutputf = dropExtension program - options = [program, "-o", binOutputf] ++ extra_options - -compareResult :: T.Text -> Int -> FilePath -> ExpectedResult [Value] -> RunResult - -> TestM () -compareResult _ _ _ (Succeeds Nothing) SuccessResult{} = - return () -compareResult entry index program (Succeeds (Just expectedResult)) (SuccessResult actualResult) = - case compareValues actualResult expectedResult of - Just mismatches -> - let reportMismatch mismatch = do - let actualf = program <.> T.unpack entry <.> show index <.> "actual" - expectedf = program <.> T.unpack entry <.> show index <.> "expected" - io $ SBS.writeFile actualf $ - T.encodeUtf8 $ T.unlines $ map prettyText actualResult - io $ SBS.writeFile expectedf $ - T.encodeUtf8 $ T.unlines $ map prettyText expectedResult - throwError $ T.pack actualf <> " and " <> T.pack expectedf <> - " do not match:\n" <> T.pack (show mismatch) <> "\n" - in mapM_ reportMismatch mismatches - Nothing -> - return () -compareResult _ _ _ (RunTimeFailure expectedError) (ErrorResult _ actualError) = - checkError expectedError actualError -compareResult _ _ _ (Succeeds _) (ErrorResult code err) = - throwError $ "Program failed with error code " <> - T.pack (show code) <> " and stderr:\n " <> T.decodeUtf8 err -compareResult _ _ _ (RunTimeFailure f) (SuccessResult _) = - throwError $ "Program succeeded, but expected failure:\n " <> T.pack (show f) - ---- ---- Test manager ---- - -data TestStatus = TestStatus { testStatusRemain :: [TestCase] - , testStatusRun :: [TestCase] - , testStatusTotal :: Int - , testStatusFail :: Int - , testStatusPass :: Int - , testStatusRuns :: Int - , testStatusRunsRemain :: Int - , testStatusRunPass :: Int - , testStatusRunFail :: Int - } - -catching :: IO TestResult -> IO TestResult -catching m = m `catch` save - where save :: SomeException -> IO TestResult - save e = return $ Failure [T.pack $ show e] - -doTest :: TestCase -> IO TestResult -doTest = catching . runTestM . runTestCase - -makeTestCase :: TestConfig -> TestMode -> (FilePath, ProgramTest) -> TestCase -makeTestCase config mode (file, spec) = - TestCase mode file spec $ configPrograms config - -data ReportMsg = TestStarted TestCase - | TestDone TestCase TestResult - -runTest :: MVar TestCase -> MVar ReportMsg -> IO () -runTest testmvar resmvar = forever $ do - test <- takeMVar testmvar - putMVar resmvar $ TestStarted test - res <- doTest test - putMVar resmvar $ TestDone test res - -excludedTest :: TestConfig -> TestCase -> Bool -excludedTest config = - any (`elem` configExclude config) . testTags . testCaseTest - -statusTable :: TestStatus -> String -statusTable ts = buildTable rows 1 - where rows = - [ [ mkEntry "", passed, failed, mkEntry "remaining"] - , map mkEntry ["programs", passedProgs, failedProgs, remainProgs'] - , map mkEntry ["runs", passedRuns, failedRuns, remainRuns'] - ] - passed = ("passed", [SetColor Foreground Vivid Green]) - failed = ("failed", [SetColor Foreground Vivid Red]) - passedProgs = show $ testStatusPass ts - failedProgs = show $ testStatusFail ts - totalProgs = show $ testStatusTotal ts - totalRuns = show $ testStatusRuns ts - passedRuns = show $ testStatusRunPass ts - failedRuns = show $ testStatusRunFail ts - remainProgs = show . length $ testStatusRemain ts - remainProgs' = remainProgs ++ "/" ++ totalProgs - remainRuns = show $ testStatusRunsRemain ts - remainRuns' = remainRuns ++ "/" ++ totalRuns - -tableLines :: Int -tableLines = 1 + (length . lines $ blankTable) - where blankTable = statusTable $ TestStatus [] [] 0 0 0 0 0 0 0 - -spaceTable :: IO () -spaceTable = putStr $ replicate tableLines '\n' - -reportTable :: TestStatus -> IO () -reportTable ts = do - moveCursorToTableTop - putStrLn $ statusTable ts - clearLine - putStrLn $ atMostChars 60 running - where running = "Now testing: " ++ - (unwords . reverse . map testCaseProgram . testStatusRun) ts - -moveCursorToTableTop :: IO () -moveCursorToTableTop = cursorUpLine tableLines - -atMostChars :: Int -> String -> String -atMostChars n s | length s > n = take (n-3) s ++ "..." - | otherwise = s - -reportText :: TestStatus -> IO () -reportText ts = - putStr $ "(" ++ show (testStatusFail ts) ++ " failed, " ++ - show (testStatusPass ts) ++ " passed, " ++ - show num_remain ++ " to go).\n" - where num_remain = length $ testStatusRemain ts - -runTests :: TestConfig -> [FilePath] -> IO () -runTests config paths = do - -- We force line buffering to ensure that we produce running output. - -- Otherwise, CI tools and the like may believe we are hung and kill - -- us. - hSetBuffering stdout LineBuffering - - let mode = configTestMode config - all_tests <- map (makeTestCase config mode) <$> testSpecsFromPaths paths - testmvar <- newEmptyMVar - reportmvar <- newEmptyMVar - concurrency <- getNumCapabilities - replicateM_ concurrency $ forkIO $ runTest testmvar reportmvar - - let (excluded, included) = partition (excludedTest config) all_tests - _ <- forkIO $ mapM_ (putMVar testmvar) included - isTTY <- (&& not (configLineOutput config)) <$> hIsTerminalDevice stdout - - let report = if isTTY then reportTable else reportText - clear = if isTTY then clearFromCursorToScreenEnd else putStr "\n" - - numTestCases tc = - case testAction $ testCaseTest tc of - CompileTimeFailure _ -> 1 - RunCases ios sts wts -> (length . concat) (iosTestRuns <$> ios) - + length sts + length wts - - getResults ts - | null (testStatusRemain ts) = report ts >> return ts - | otherwise = do - report ts - msg <- takeMVar reportmvar - case msg of - TestStarted test -> do - unless isTTY $ - putStr $ "Started testing " <> testCaseProgram test <> " " - getResults $ ts {testStatusRun = test : testStatusRun ts} - TestDone test res -> do - let ts' = ts { testStatusRemain = test `delete` testStatusRemain ts - , testStatusRun = test `delete` testStatusRun ts - , testStatusRunsRemain = testStatusRunsRemain ts - - numTestCases test - } - case res of - Success -> do - let ts'' = ts' { testStatusRunPass = - testStatusRunPass ts' + numTestCases test - } - unless isTTY $ - putStr $ "Finished testing " <> testCaseProgram test <> " " - getResults $ ts'' { testStatusPass = testStatusPass ts + 1} - Failure s -> do - when isTTY moveCursorToTableTop - clear - T.putStrLn $ (T.pack (inRed $ testCaseProgram test) <> ":\n") <> T.concat s - when isTTY spaceTable - getResults $ ts' { testStatusFail = testStatusFail ts' + 1 - , testStatusRunPass = testStatusRunPass ts' - + numTestCases test - length s - - , testStatusRunFail = testStatusRunFail ts' - + length s - } - - when isTTY spaceTable - - ts <- getResults TestStatus { testStatusRemain = included - , testStatusRun = [] - , testStatusTotal = length included - , testStatusFail = 0 - , testStatusPass = 0 - , testStatusRuns = sum $ map numTestCases included - , testStatusRunsRemain = sum $ map numTestCases included - , testStatusRunPass = 0 - , testStatusRunFail = 0 - } - - -- Removes "Now testing" output. - when isTTY $ cursorUpLine 1 >> clearLine - - let excluded_str = if null excluded - then "" - else " (" ++ show (length excluded) ++ " program(s) excluded).\n" - putStr excluded_str - exitWith $ case testStatusFail ts of 0 -> ExitSuccess - _ -> ExitFailure 1 - -inRed :: String -> String -inRed s = setSGRCode [SetColor Foreground Vivid Red] ++ s ++ setSGRCode [Reset] - ---- ---- Configuration and command line parsing ---- - -data TestConfig = TestConfig - { configTestMode :: TestMode - , configPrograms :: ProgConfig - , configExclude :: [T.Text] - , configLineOutput :: Bool - } - -defaultConfig :: TestConfig -defaultConfig = TestConfig { configTestMode = Everything - , configExclude = [ "disable" ] - , configPrograms = - ProgConfig - { configCompiler = "futhark-c" - , configInterpreter = "futharki" - , configTypeChecker = "futhark" - , configRunner = "" - , configExtraOptions = [] - , configExtraCompilerOptions = [] - } - , configLineOutput = False - } - -data ProgConfig = ProgConfig - { configCompiler :: FilePath - , configInterpreter :: FilePath - , configTypeChecker :: FilePath - , configRunner :: FilePath - , configExtraCompilerOptions :: [String] - , configExtraOptions :: [String] - -- ^ Extra options passed to the programs being run. - } - deriving (Show) - -changeProgConfig :: (ProgConfig -> ProgConfig) -> TestConfig -> TestConfig -changeProgConfig f config = config { configPrograms = f $ configPrograms config } - -setCompiler :: FilePath -> ProgConfig -> ProgConfig -setCompiler compiler config = - config { configCompiler = compiler } - -setInterpreter :: FilePath -> ProgConfig -> ProgConfig -setInterpreter interpreter config = - config { configInterpreter = interpreter } - -setTypeChecker :: FilePath -> ProgConfig -> ProgConfig -setTypeChecker typeChecker config = - config { configTypeChecker = typeChecker } - -setRunner :: FilePath -> ProgConfig -> ProgConfig -setRunner runner config = - config { configRunner = runner } - -addCompilerOption :: String -> ProgConfig -> ProgConfig -addCompilerOption option config = - config { configExtraCompilerOptions = configExtraCompilerOptions config ++ [option] } - -addOption :: String -> ProgConfig -> ProgConfig -addOption option config = - config { configExtraOptions = configExtraOptions config ++ [option] } - -data TestMode = TypeCheck - | Compile - | Compiled - | Interpreted - | Everything - deriving (Eq, Show) - -commandLineOptions :: [FunOptDescr TestConfig] -commandLineOptions = [ - Option "t" ["typecheck"] - (NoArg $ Right $ \config -> config { configTestMode = TypeCheck }) - "Only perform type-checking" - , Option "i" ["interpreted"] - (NoArg $ Right $ \config -> config { configTestMode = Interpreted }) - "Only interpret" - , Option "c" ["compiled"] - (NoArg $ Right $ \config -> config { configTestMode = Compiled }) - "Only run compiled code" - , Option "C" ["compile"] - (NoArg $ Right $ \config -> config { configTestMode = Compile }) - "Only compile, do not run." - , Option [] ["no-terminal", "notty"] - (NoArg $ Right $ \config -> config { configLineOutput = True }) - "Provide simpler line-based output." - , Option [] ["typechecker"] - (ReqArg (Right . changeProgConfig . setTypeChecker) "PROGRAM") - "What to run for type-checking (defaults to 'futhark')." - , Option [] ["compiler"] - (ReqArg (Right . changeProgConfig . setCompiler) "PROGRAM") - "What to run for code generation (defaults to 'futhark-c')." - , Option [] ["interpreter"] - (ReqArg (Right . changeProgConfig . setInterpreter) "PROGRAM") - "What to run for interpretation (defaults to 'futharki')." - , Option [] ["runner"] - (ReqArg (Right . changeProgConfig . setRunner) "PROGRAM") - "The program used to run the Futhark-generated programs (defaults to nothing)." - , Option [] ["exclude"] - (ReqArg (\tag -> - Right $ \config -> - config { configExclude = T.pack tag : configExclude config }) - "TAG") - "Exclude test programs that define this tag." - , Option "p" ["pass-option"] - (ReqArg (Right . changeProgConfig . addOption) "OPT") - "Pass this option to programs being run." - , Option [] ["pass-compiler-option"] - (ReqArg (Right . changeProgConfig . addCompilerOption) "OPT") - "Pass this option to the compiler (or typechecker if in -t mode)." - ] - -main :: IO () -main = mainWithOptions defaultConfig commandLineOptions "options... programs..." $ \progs config -> - Just $ runTests config progs diff --git a/src/futhark.hs b/src/futhark.hs --- a/src/futhark.hs +++ b/src/futhark.hs @@ -1,402 +1,103 @@ -{-# LANGUAGE RankNTypes #-} --- | Futhark Compiler Driver +{-# LANGUAGE OverloadedStrings #-} +-- | The futhark command line tool. module Main (main) where import Data.Maybe -import Control.Category (id) +import Control.Exception import Control.Monad -import Control.Monad.State -import Data.Semigroup ((<>)) +import Data.List +import qualified Data.Text as T import qualified Data.Text.IO as T import System.IO import System.Exit -import System.Console.GetOpt +import System.Environment -import Prelude hiding (id) +import Prelude -import Futhark.Pass -import Futhark.Actions -import Futhark.Compiler -import Language.Futhark.Parser (parseFuthark) import Futhark.Util.Options -import Futhark.Pipeline -import qualified Futhark.Representation.SOACS as SOACS -import Futhark.Representation.SOACS (SOACS) -import qualified Futhark.Representation.Kernels as Kernels -import Futhark.Representation.Kernels (Kernels) -import qualified Futhark.Representation.ExplicitMemory as ExplicitMemory -import Futhark.Representation.ExplicitMemory (ExplicitMemory) -import Futhark.Representation.AST (Prog, pretty) -import Futhark.TypeCheck (Checkable) -import qualified Futhark.Util.Pretty as PP -import Futhark.Internalise.Defunctorise as Defunctorise -import Futhark.Internalise.Monomorphise as Monomorphise -import Futhark.Internalise.Defunctionalise as Defunctionalise -import Futhark.Optimise.InliningDeadFun -import Futhark.Optimise.CSE -import Futhark.Optimise.Fusion -import Futhark.Pass.FirstOrderTransform -import Futhark.Pass.Simplify -import Futhark.Optimise.InPlaceLowering -import Futhark.Optimise.DoubleBuffer -import Futhark.Optimise.TileLoops -import Futhark.Optimise.Unstream -import Futhark.Pass.KernelBabysitting -import Futhark.Pass.ExtractKernels -import Futhark.Pass.ExpandAllocations -import Futhark.Pass.ExplicitAllocations -import Futhark.Passes - --- | What to do with the program after it has been read. -data FutharkPipeline = PrettyPrint - -- ^ Just print it. - | TypeCheck - -- ^ Run the type checker; print type errors. - | Pipeline [UntypedPass] - -- ^ Run this pipeline. - | Defunctorise - -- ^ Partially evaluate away the module language. - | Monomorphise - -- ^ Defunctorise and monomorphise. - | Defunctionalise - -- ^ Defunctorise, monomorphise, and defunctionalise. - -data Config = Config { futharkConfig :: FutharkConfig - , futharkPipeline :: FutharkPipeline - -- ^ Nothing is distinct from a empty pipeline - - -- it means we don't even run the internaliser. - , futharkAction :: UntypedAction - } - - --- | Get a Futhark pipeline from the configuration - an empty one if --- none exists. -getFutharkPipeline :: Config -> [UntypedPass] -getFutharkPipeline = toPipeline . futharkPipeline - where toPipeline (Pipeline p) = p - toPipeline _ = [] - -data UntypedPassState = SOACS (Prog SOACS.SOACS) - | Kernels (Prog Kernels.Kernels) - | ExplicitMemory (Prog ExplicitMemory.ExplicitMemory) - -getSOACSProg :: UntypedPassState -> Maybe (Prog SOACS.SOACS) -getSOACSProg (SOACS prog) = Just prog -getSOACSProg _ = Nothing - -class Representation s where - -- | A human-readable description of the representation expected or - -- contained, usable for error messages. - representation :: s -> String - -instance Representation UntypedPassState where - representation (SOACS _) = "SOACS" - representation (Kernels _) = "Kernels" - representation (ExplicitMemory _) = "ExplicitMemory" - -instance PP.Pretty UntypedPassState where - ppr (SOACS prog) = PP.ppr prog - ppr (Kernels prog) = PP.ppr prog - ppr (ExplicitMemory prog) = PP.ppr prog - -newtype UntypedPass = UntypedPass (UntypedPassState - -> PipelineConfig - -> FutharkM UntypedPassState) - -data UntypedAction = SOACSAction (Action SOACS) - | KernelsAction (Action Kernels) - | ExplicitMemoryAction (Action ExplicitMemory) - | PolyAction (Action SOACS) (Action Kernels) (Action ExplicitMemory) - -untypedActionName :: UntypedAction -> String -untypedActionName (SOACSAction a) = actionName a -untypedActionName (KernelsAction a) = actionName a -untypedActionName (ExplicitMemoryAction a) = actionName a -untypedActionName (PolyAction a _ _) = actionName a - -instance Representation UntypedAction where - representation (SOACSAction _) = "SOACS" - representation (KernelsAction _) = "Kernels" - representation (ExplicitMemoryAction _) = "ExplicitMemory" - representation PolyAction{} = "" - -newConfig :: Config -newConfig = Config newFutharkConfig (Pipeline []) $ PolyAction printAction printAction printAction - -changeFutharkConfig :: (FutharkConfig -> FutharkConfig) - -> Config -> Config -changeFutharkConfig f cfg = cfg { futharkConfig = f $ futharkConfig cfg } - -type FutharkOption = FunOptDescr Config - -passOption :: String -> UntypedPass -> String -> [String] -> FutharkOption -passOption desc pass short long = - Option short long - (NoArg $ Right $ \cfg -> - cfg { futharkPipeline = Pipeline $ getFutharkPipeline cfg ++ [pass] }) - desc - -explicitMemoryProg :: String -> UntypedPassState -> FutharkM (Prog ExplicitMemory.ExplicitMemory) -explicitMemoryProg _ (ExplicitMemory prog) = - return prog -explicitMemoryProg name rep = - externalErrorS $ "Pass " ++ name ++ - " expects ExplicitMemory representation, but got " ++ representation rep - -soacsProg :: String -> UntypedPassState -> FutharkM (Prog SOACS.SOACS) -soacsProg _ (SOACS prog) = - return prog -soacsProg name rep = - externalErrorS $ "Pass " ++ name ++ - " expects SOACS representation, but got " ++ representation rep - -kernelsProg :: String -> UntypedPassState -> FutharkM (Prog Kernels.Kernels) -kernelsProg _ (Kernels prog) = - return prog -kernelsProg name rep = - externalErrorS $ - "Pass " ++ name ++" expects Kernels representation, but got " ++ representation rep - -typedPassOption :: (Checkable fromlore, Checkable tolore) => - (String -> UntypedPassState -> FutharkM (Prog fromlore)) - -> (Prog tolore -> UntypedPassState) - -> Pass fromlore tolore - -> String - -> FutharkOption -typedPassOption getProg putProg pass short = - passOption (passDescription pass) (UntypedPass perform) short long - where perform s config = do - prog <- getProg (passName pass) s - putProg <$> runPasses (onePass pass) config prog - - long = [passLongOption pass] - -soacsPassOption :: Pass SOACS SOACS -> String -> FutharkOption -soacsPassOption = - typedPassOption soacsProg SOACS - -kernelsPassOption :: Pass Kernels Kernels -> String -> FutharkOption -kernelsPassOption = - typedPassOption kernelsProg Kernels - -explicitMemoryPassOption :: Pass ExplicitMemory ExplicitMemory -> String -> FutharkOption -explicitMemoryPassOption = - typedPassOption explicitMemoryProg ExplicitMemory - -simplifyOption :: String -> FutharkOption -simplifyOption short = - passOption (passDescription pass) (UntypedPass perform) short long - where perform (SOACS prog) config = - SOACS <$> runPasses (onePass simplifySOACS) config prog - perform (Kernels prog) config = - Kernels <$> runPasses (onePass simplifyKernels) config prog - perform (ExplicitMemory prog) config = - ExplicitMemory <$> runPasses (onePass simplifyExplicitMemory) config prog - - long = [passLongOption pass] - pass = simplifySOACS - -cseOption :: String -> FutharkOption -cseOption short = - passOption (passDescription pass) (UntypedPass perform) short long - where perform (SOACS prog) config = - SOACS <$> runPasses (onePass $ performCSE True) config prog - perform (Kernels prog) config = - Kernels <$> runPasses (onePass $ performCSE True) config prog - perform (ExplicitMemory prog) config = - ExplicitMemory <$> runPasses (onePass $ performCSE False) config prog - - long = [passLongOption pass] - pass = performCSE True :: Pass SOACS SOACS - -pipelineOption :: (UntypedPassState -> Maybe (Prog fromlore)) - -> String - -> (Prog tolore -> UntypedPassState) - -> String - -> Pipeline fromlore tolore - -> String - -> [String] - -> FutharkOption -pipelineOption getprog repdesc repf desc pipeline = - passOption desc $ UntypedPass pipelinePass - where pipelinePass rep config = - case getprog rep of - Just prog -> - repf <$> runPasses pipeline config prog - Nothing -> - externalErrorS $ "Expected " ++ repdesc ++ " representation, but got " ++ - representation rep +import qualified Futhark.CLI.Dev as Dev +import qualified Futhark.CLI.C as C +import qualified Futhark.CLI.OpenCL as OpenCL +import qualified Futhark.CLI.CUDA as CCUDA +import qualified Futhark.CLI.Python as Python +import qualified Futhark.CLI.PyOpenCL as PyOpenCL +import qualified Futhark.CLI.CSharp as CSharp +import qualified Futhark.CLI.CSOpenCL as CSOpenCL +import qualified Futhark.CLI.Test as Test +import qualified Futhark.CLI.Bench as Bench +import qualified Futhark.CLI.Dataset as Dataset +import qualified Futhark.CLI.Datacmp as Datacmp +import qualified Futhark.CLI.Pkg as Pkg +import qualified Futhark.CLI.Doc as Doc +import qualified Futhark.CLI.REPL as REPL +import qualified Futhark.CLI.Run as Run +import qualified Futhark.CLI.Misc as Misc -soacsPipelineOption :: String -> Pipeline SOACS SOACS -> String -> [String] - -> FutharkOption -soacsPipelineOption = pipelineOption getSOACSProg "SOACS" SOACS +type Command = String -> [String] -> IO () -kernelsPipelineOption :: String -> Pipeline SOACS Kernels -> String -> [String] - -> FutharkOption -kernelsPipelineOption = pipelineOption getSOACSProg "Kernels" Kernels +commands :: [(String, (Command, String))] +commands = sortOn fst + [ ("dev", (Dev.main, "Run compiler passes directly.")) -explicitMemoryPipelineOption :: String -> Pipeline SOACS ExplicitMemory -> String -> [String] - -> FutharkOption -explicitMemoryPipelineOption = pipelineOption getSOACSProg "ExplicitMemory" ExplicitMemory + , ("repl", (REPL.main, "Run interactive Read-Eval-Print-Loop.")) + , ("run", (Run.main, "Run a program through the (slow!) interpreter.")) -commandLineOptions :: [FutharkOption] -commandLineOptions = - [ Option "v" ["verbose"] - (OptArg (Right . changeFutharkConfig . incVerbosity) "FILE") - "Print verbose output on standard error; wrong program to FILE." - , Option [] ["Werror"] - (NoArg $ Right $ changeFutharkConfig $ \opts -> opts { futharkWerror = True }) - "Treat warnings as errors." + , ("c", (C.main, "Compile to sequential C.")) + , ("opencl", (OpenCL.main, "Compile to C calling OpenCL.")) + , ("cuda", (CCUDA.main, "Compile to C calling CUDA.")) - , Option "t" ["type-check"] - (NoArg $ Right $ \opts -> - opts { futharkPipeline = TypeCheck }) - "Type-check the program and print errors on standard error." + , ("python", (Python.main, "Compile to sequential Python.")) + , ("pyopencl", (PyOpenCL.main, "Compile to Python calling PyOpenCL.")) - , Option [] ["pretty-print"] - (NoArg $ Right $ \opts -> - opts { futharkPipeline = PrettyPrint }) - "Parse and pretty-print the AST of the given program." + , ("csharp", (CSharp.main, "Compile to sequential C#.")) + , ("csopencl", (CSOpenCL.main, "Compile to C# calling OpenCL.")) - , Option [] ["compile-imperative"] - (NoArg $ Right $ \opts -> - opts { futharkAction = ExplicitMemoryAction impCodeGenAction }) - "Translate program into the imperative IL and write it on standard output." - , Option [] ["compile-imperative-kernels"] - (NoArg $ Right $ \opts -> - opts { futharkAction = ExplicitMemoryAction kernelImpCodeGenAction }) - "Translate program into the imperative IL with kernels and write it on standard output." - , Option [] ["range-analysis"] - (NoArg $ Right $ \opts -> opts { futharkAction = PolyAction rangeAction rangeAction rangeAction }) - "Print the program with range annotations added." - , Option "p" ["print"] - (NoArg $ Right $ \opts -> opts { futharkAction = PolyAction printAction printAction printAction }) - "Prettyprint the resulting internal representation on standard output (default action)." - , Option "m" ["metrics"] - (NoArg $ Right $ \opts -> opts { futharkAction = PolyAction metricsAction metricsAction metricsAction }) - "Print AST metrics of the resulting internal representation on standard output." - , Option [] ["defunctorise"] - (NoArg $ Right $ \opts -> opts { futharkPipeline = Defunctorise }) - "Partially evaluate all module constructs and print the residual program." - , Option [] ["monomorphise"] - (NoArg $ Right $ \opts -> opts { futharkPipeline = Monomorphise }) - "Monomorphise the program." - , Option [] ["defunctionalise"] - (NoArg $ Right $ \opts -> opts { futharkPipeline = Defunctionalise }) - "Defunctionalise the program." - , typedPassOption soacsProg Kernels firstOrderTransform "f" - , soacsPassOption fuseSOACs "o" - , soacsPassOption inlineAndRemoveDeadFunctions [] - , kernelsPassOption inPlaceLowering [] - , kernelsPassOption babysitKernels [] - , kernelsPassOption tileLoops [] - , kernelsPassOption unstream [] - , typedPassOption soacsProg Kernels extractKernels [] + , ("test", (Test.main, "Test Futhark programs.")) + , ("bench", (Bench.main, "Test Futhark programs.")) - , typedPassOption kernelsProg ExplicitMemory explicitAllocations "a" + , ("dataset", (Dataset.main, "Generate random test data.")) + , ("datacmp", (Datacmp.main, "Compare Futhark data files for equality.")) - , explicitMemoryPassOption doubleBuffer [] - , explicitMemoryPassOption expandAllocations [] + , ("doc", (Doc.main, "Generate documentation for Futhark code.")) + , ("pkg", (Pkg.main, "Manage local packages.")) - , cseOption [] - , simplifyOption "e" + , ("check", (Misc.mainCheck, "Type check a program.")) + ] - , soacsPipelineOption "Run the default optimised pipeline" - standardPipeline "s" ["standard"] - , kernelsPipelineOption "Run the default optimised kernels pipeline" - kernelsPipeline [] ["kernels"] - , explicitMemoryPipelineOption "Run the full GPU compilation pipeline" - gpuPipeline [] ["gpu"] - , explicitMemoryPipelineOption "Run the sequential CPU compilation pipeline" - sequentialCpuPipeline [] ["cpu"] - ] +msg :: String +msg = unlines $ + [" options...", "Commands:", ""] ++ + [ " " <> cmd <> replicate (k - length cmd) ' ' <> desc + | (cmd, (_, desc)) <- commands ] + where k = maximum (map (length . fst) commands) + 3 -incVerbosity :: Maybe FilePath -> FutharkConfig -> FutharkConfig -incVerbosity file cfg = - cfg { futharkVerbose = (v, file `mplus` snd (futharkVerbose cfg)) } - where v = case fst $ futharkVerbose cfg of - NotVerbose -> Verbose - Verbose -> VeryVerbose - VeryVerbose -> VeryVerbose +-- | Catch all IO exceptions and print a better error message if they +-- happen. +reportingIOErrors :: IO () -> IO () +reportingIOErrors = flip catches [Handler onExit, Handler onError] + where onExit :: ExitCode -> IO () + onExit = throwIO + onError :: SomeException -> IO () + onError e + | Just UserInterrupt <- asyncExceptionFromException e = + return () -- This corresponds to CTRL-C, which is not an error. + | otherwise = do + T.hPutStrLn stderr "Internal compiler error (unhandled IO exception)." + T.hPutStrLn stderr "Please report this at https://github.com/diku-dk/futhark/issues" + T.hPutStrLn stderr $ T.pack $ show e + exitWith $ ExitFailure 1 --- | Entry point. Non-interactive, except when reading interpreter --- input from standard input. main :: IO () -main = do +main = reportingIOErrors $ do hSetEncoding stdout utf8 hSetEncoding stderr utf8 - mainWithOptions newConfig commandLineOptions "options... program" compile - where compile [file] config = - Just $ do - res <- runFutharkM (m file config) $ - fst $ futharkVerbose $ futharkConfig config - case res of - Left err -> do - dumpError (futharkConfig config) err - exitWith $ ExitFailure 2 - Right () -> return () - compile _ _ = - Nothing - m file config = - case futharkPipeline config of - TypeCheck -> do - -- No pipeline; just read the program and type check - (warnings, _, _) <- readProgram file - liftIO $ hPutStr stderr $ show warnings - PrettyPrint -> liftIO $ do - maybe_prog <- parseFuthark file <$> T.readFile file - case maybe_prog of - Left err -> fail $ show err - Right prog-> putStrLn $ pretty prog - Defunctorise -> do - (_, imports, src) <- readProgram file - liftIO $ mapM_ (putStrLn . pretty) $ - evalState (Defunctorise.transformProg imports) src - Monomorphise -> do - (_, imports, src) <- readProgram file - liftIO $ mapM_ (putStrLn . pretty) $ flip evalState src $ - Defunctorise.transformProg imports - >>= Monomorphise.transformProg - Defunctionalise -> do - (_, imports, src) <- readProgram file - liftIO $ mapM_ (putStrLn . pretty) $ flip evalState src $ - Defunctorise.transformProg imports - >>= Monomorphise.transformProg - >>= Defunctionalise.transformProg - Pipeline{} -> do - prog <- runPipelineOnProgram (futharkConfig config) id file - runPolyPasses config prog - -runPolyPasses :: Config -> SOACS.Prog -> FutharkM () -runPolyPasses config prog = do - prog' <- foldM (runPolyPass pipeline_config) (SOACS prog) (getFutharkPipeline config) - case (prog', futharkAction config) of - (SOACS soacs_prog, SOACSAction action) -> - actionProcedure action soacs_prog - (Kernels kernels_prog, KernelsAction action) -> - actionProcedure action kernels_prog - (ExplicitMemory mem_prog, ExplicitMemoryAction action) -> - actionProcedure action mem_prog - - (SOACS soacs_prog, PolyAction soacs_action _ _) -> - actionProcedure soacs_action soacs_prog - (Kernels kernels_prog, PolyAction _ kernels_action _) -> - actionProcedure kernels_action kernels_prog - (ExplicitMemory mem_prog, PolyAction _ _ mem_action) -> - actionProcedure mem_action mem_prog - - (_, action) -> - externalErrorS $ "Action " <> - untypedActionName action <> - " expects " ++ representation action ++ " representation, but got " ++ - representation prog' ++ "." - where pipeline_config = - PipelineConfig { pipelineVerbose = fst (futharkVerbose $ futharkConfig config) > NotVerbose - , pipelineValidate = True - } - -runPolyPass :: PipelineConfig - -> UntypedPassState -> UntypedPass -> FutharkM UntypedPassState -runPolyPass pipeline_config s (UntypedPass f) = - f s pipeline_config + args <- getArgs + prog <- getProgName + case args of + -- The -t case here is for temporary compatibility with + -- futhark-mode. It will go away eventually. + "-t":args' -> Misc.mainCheck prog args' + cmd:args' + | Just (m, _) <- lookup cmd commands -> m (unwords [prog, cmd]) args' + _ -> mainWithOptions () [] msg (const . const Nothing) prog args diff --git a/src/futharki.hs b/src/futharki.hs --- a/src/futharki.hs +++ b/src/futharki.hs @@ -1,462 +1,19 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main (main) where -import Control.Monad.Free.Church -import Control.Exception -import Data.Array -import Data.Char -import Data.List -import Data.Loc -import Data.Maybe -import Data.Version -import qualified Data.Map as M -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.State -import Control.Monad.Except -import Data.Semigroup ((<>)) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import NeatInterpolation (text) -import System.Directory -import System.FilePath -import System.Exit -import System.Console.GetOpt +import System.Environment +import System.Process import System.IO -import qualified System.Console.Haskeline as Haskeline - -import Language.Futhark -import Language.Futhark.Parser hiding (EOF) -import qualified Language.Futhark.TypeChecker as T -import qualified Language.Futhark.Semantic as T -import Futhark.MonadFreshNames -import Futhark.Version -import Futhark.Compiler -import Futhark.Pipeline -import Futhark.Util.Options -import Futhark.Util (toPOSIX, maybeHead) - -import qualified Language.Futhark.Interpreter as I - -banner :: String -banner = unlines [ - "|// |\\ | |\\ |\\ /", - "|/ | \\ |\\ |\\ |/ /", - "| | \\ |/ | |\\ \\", - "| | \\ | | | \\ \\" - ] +import System.Exit main :: IO () -main = reportingIOErrors $ - mainWithOptions interpreterConfig options "options... program" run - where run [prog] config = Just $ interpret config prog - run [] _ = Just repl - run _ _ = Nothing - -data StopReason = EOF | Stop | Exit | Load FilePath - -repl :: IO () -repl = do - putStr banner - putStrLn $ "Version " ++ showVersion version ++ "." - putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license." - putStrLn "" - putStrLn "Run :help for a list of commands." - putStrLn "" - - let toploop s = do - (stop, s') <- runStateT (runExceptT $ runFutharkiM $ forever readEvalPrint) s - case stop of - Left Stop -> finish s' - Left EOF -> finish s' - Left Exit -> finish s' - Left (Load file) -> do - liftIO $ T.putStrLn $ "Loading " <> T.pack file - maybe_new_state <- - liftIO $ newFutharkiState (futharkiCount s) $ Just file - case maybe_new_state of - Right new_state -> toploop new_state - Left err -> do liftIO $ putStrLn err - toploop s' - Right _ -> return () - - finish s = do - quit <- confirmQuit - if quit then return () else toploop s - - maybe_init_state <- liftIO $ newFutharkiState 0 Nothing - case maybe_init_state of - Left err -> error $ "Failed to initialise intepreter state: " ++ err - Right init_state -> Haskeline.runInputT Haskeline.defaultSettings $ toploop init_state - - putStrLn "Leaving futharki." - -confirmQuit :: Haskeline.InputT IO Bool -confirmQuit = do - c <- Haskeline.getInputChar "Quit futharki? (y/n) " - case c of - Nothing -> return True -- EOF - Just 'y' -> return True - Just 'n' -> return False - _ -> confirmQuit - -interpret :: InterpreterConfig -> FilePath -> IO () -interpret config fp = do - pr <- newFutharkiState 0 $ Just fp - env <- case pr of Left err -> do hPutStrLn stderr err - exitFailure - Right env -> return env - - let entry = interpreterEntryPoint config - (tenv, ienv) = futharkiEnv env - vr <- parseValues "stdin" <$> T.getContents - - inps <- - case vr of - Left err -> do - hPutStrLn stderr $ "Error when reading input: " ++ show err - exitFailure - Right vs - | Just vs' <- mapM convertValue vs -> - return vs' - | otherwise -> do - hPutStrLn stderr "Error when reading input: irregular array." - exitFailure - - (fname, ret) <- - case M.lookup (T.Term, entry) $ T.envNameMap tenv of - Just fname - | Just (T.BoundV _ t) <- M.lookup (qualLeaf fname) $ T.envVtable tenv -> - return (fname, toStructural $ snd $ unfoldFunType t) - _ -> do hPutStrLn stderr $ "Invalid entry point: " ++ pretty entry - exitFailure - - r <- runInterpreter' $ I.interpretFunction ienv (qualLeaf fname) inps - case r of - Left err -> do hPrint stderr err - exitFailure - Right res -> - case (I.fromTuple res, isTupleRecord ret) of - (Just vs, Just ts) -> zipWithM_ putValue vs ts - _ -> putValue res ret - -putValue :: I.Value -> TypeBase () () -> IO () -putValue v t - | I.isEmptyArray v = - putStrLn $ "empty(" ++ pretty (stripArray 1 t) ++ ")" - | otherwise = putStrLn $ pretty v - -convertValue :: Value -> Maybe I.Value -convertValue (PrimValue p) = Just $ I.ValuePrim p -convertValue (ArrayValue arr _) = I.mkArray =<< mapM convertValue (elems arr) - -newtype InterpreterConfig = InterpreterConfig { interpreterEntryPoint :: Name } - -interpreterConfig :: InterpreterConfig -interpreterConfig = InterpreterConfig defaultEntryPoint - -options :: [FunOptDescr InterpreterConfig] -options = [ Option "e" ["entry-point"] - (ReqArg (\entry -> Right $ \config -> - config { interpreterEntryPoint = nameFromString entry }) - "NAME") - "The entry point to execute." - ] - -data FutharkiState = - FutharkiState { futharkiImports :: Imports - , futharkiNameSource :: VNameSource - , futharkiCount :: Int - , futharkiEnv :: (T.Env, I.Ctx) - , futharkiBreaking :: Maybe Loc - -- ^ Are we currently stopped at a breakpoint? - , futharkiSkipBreaks :: [Loc] - -- ^ Skip breakpoints at these locations. - , futharkiLoaded :: Maybe FilePath - -- ^ The currently loaded file. - } - -newFutharkiState :: Int -> Maybe FilePath -> IO (Either String FutharkiState) -newFutharkiState count maybe_file = runExceptT $ do - (imports, src, tenv, ienv) <- case maybe_file of - - Nothing -> do - -- Load the builtins through the type checker. - (_, imports, src) <- badOnLeft =<< runExceptT (readLibrary []) - -- Then into the interpreter. - ienv <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) - I.initialCtx $ map (fmap fileProg) imports - - -- Then make the prelude available in the type checker. - (tenv, d, src') <- badOnLeft $ T.checkDec imports src T.initialEnv - (T.mkInitialImport ".") $ mkOpen "/futlib/prelude" - -- Then in the interpreter. - ienv' <- badOnLeft =<< runInterpreter' (I.interpretDec ienv d) - return (imports, src', tenv, ienv') - - Just file -> do - (ws, imports, src) <- - badOnLeft =<< liftIO (runExceptT (readProgram file) - `Haskeline.catch` \(err::IOException) -> - return (Left (ExternalError (T.pack $ show err)))) - liftIO $ hPrint stderr ws - - let imp = T.mkInitialImport "." - ienv1 <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $ - map (fmap fileProg) imports - (tenv1, d1, src') <- badOnLeft $ T.checkDec imports src T.initialEnv imp $ - mkOpen "/futlib/prelude" - (tenv2, d2, src'') <- badOnLeft $ T.checkDec imports src' tenv1 imp $ - mkOpen $ toPOSIX $ dropExtension file - ienv2 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv1 d1) - ienv3 <- badOnLeft =<< runInterpreter' (I.interpretDec ienv2 d2) - return (imports, src'', tenv2, ienv3) - - return FutharkiState { futharkiImports = imports - , futharkiNameSource = src - , futharkiCount = count - , futharkiEnv = (tenv, ienv) - , futharkiBreaking = Nothing - , futharkiSkipBreaks = mempty - , futharkiLoaded = maybe_file - } - where badOnLeft :: Show err => Either err a -> ExceptT String IO a - badOnLeft (Right x) = return x - badOnLeft (Left err) = throwError $ show err - -getPrompt :: FutharkiM String -getPrompt = do - i <- gets futharkiCount - return $ "[" ++ show i ++ "]> " - -mkOpen :: FilePath -> UncheckedDec -mkOpen f = OpenDec (ModImport f NoInfo noLoc) noLoc - --- The ExceptT part is more of a continuation, really. -newtype FutharkiM a = - FutharkiM { runFutharkiM :: ExceptT StopReason (StateT FutharkiState (Haskeline.InputT IO)) a } - deriving (Functor, Applicative, Monad, - MonadState FutharkiState, MonadIO, MonadError StopReason) - -readEvalPrint :: FutharkiM () -readEvalPrint = do - prompt <- getPrompt - line <- inputLine prompt - breaking <- gets futharkiBreaking - case T.uncons line of - Nothing - | isJust breaking -> throwError Stop - | otherwise -> return () - - Just (':', command) -> do - let (cmdname, rest) = T.break isSpace command - arg = T.dropWhileEnd isSpace $ T.dropWhile isSpace rest - case filter ((cmdname `T.isPrefixOf`) . fst) commands of - [] -> liftIO $ T.putStrLn $ "Unknown command '" <> cmdname <> "'" - [(_, (cmdf, _))] -> cmdf arg - matches -> liftIO $ T.putStrLn $ "Ambiguous command; could be one of " <> - mconcat (intersperse ", " (map fst matches)) - - _ -> do - -- Read a declaration or expression. - maybe_dec_or_e <- parseDecOrExpIncrM (inputLine " ") prompt line - - case maybe_dec_or_e of - Left err -> liftIO $ print err - Right (Left d) -> onDec d - Right (Right e) -> onExp e - modify $ \s -> s { futharkiCount = futharkiCount s + 1 } - where inputLine prompt = do - inp <- FutharkiM $ lift $ lift $ Haskeline.getInputLine prompt - case inp of - Just s -> return $ T.pack s - Nothing -> throwError EOF - -getIt :: FutharkiM (Imports, VNameSource, T.Env, I.Ctx) -getIt = do - imports <- gets futharkiImports - src <- gets futharkiNameSource - (tenv, ienv) <- gets futharkiEnv - return (imports, src, tenv, ienv) - -onDec :: UncheckedDec -> FutharkiM () -onDec d = do - (imports, src, tenv, ienv) <- getIt - cur_import <- T.mkInitialImport . fromMaybe "." <$> gets futharkiLoaded - - -- Most of the complexity here concerns the dealing with the fact - -- that 'import "foo"' is a declaration. We have to involve a lot - -- of machinery to load this external code before executing the - -- declaration itself. - let basis = Basis imports src ["/futlib/prelude"] - mkImport = uncurry $ T.mkImportFrom cur_import - imp_r <- runExceptT $ readImports basis (map mkImport $ decImports d) - - case imp_r of - Left e -> liftIO $ print e - Right (_, imports', src') -> - case T.checkDec imports' src' tenv cur_import d of - Left e -> liftIO $ print e - Right (tenv', d', src'') -> do - let new_imports = filter ((`notElem` map fst imports) . fst) imports' - int_r <- runInterpreter $ do - let onImport ienv' (s, imp) = - I.interpretImport ienv' (s, T.fileProg imp) - ienv' <- foldM onImport ienv new_imports - I.interpretDec ienv' d' - case int_r of - Left err -> liftIO $ print err - Right ienv' -> modify $ \s -> s { futharkiEnv = (tenv', ienv') - , futharkiImports = imports' - , futharkiNameSource = src'' - } - -onExp :: UncheckedExp -> FutharkiM () -onExp e = do - (imports, src, tenv, ienv) <- getIt - case showErr (T.checkExp imports src tenv e) of - Left err -> liftIO $ putStrLn err - Right (_, e') -> do - r <- runInterpreter $ I.interpretExp ienv e' - case r of - Left err -> liftIO $ print err - Right v -> liftIO $ putStrLn $ pretty v - where showErr :: Show a => Either a b -> Either String b - showErr = either (Left . show) Right - -runInterpreter :: F I.ExtOp a -> FutharkiM (Either I.InterpreterError a) -runInterpreter m = runF m (return . Right) intOp - where - intOp (I.ExtOpError err) = - return $ Left err - intOp (I.ExtOpTrace w v c) = do - liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v - c - intOp (I.ExtOpBreak w ctx tenv c) = do - s <- get - - -- Are we supposed to skip this breakpoint? - let loc = maybe noLoc locOf $ maybeHead w - - -- We do not want recursive breakpoints. It could work fine - -- technically, but is probably too confusing to be useful. - unless (isJust (futharkiBreaking s) || loc `elem` futharkiSkipBreaks s) $ do - liftIO $ putStrLn $ "Breaking at " ++ intercalate " -> " (map locStr w) ++ "." - liftIO $ putStrLn " to continue." - - -- Note the cleverness to preserve the Haskeline session (for - -- line history and such). - (stop, s') <- - FutharkiM $ lift $ lift $ - runStateT (runExceptT $ runFutharkiM $ forever readEvalPrint) - s { futharkiEnv = (tenv, ctx) - , futharkiCount = futharkiCount s + 1 - , futharkiBreaking = Just loc } - - case stop of - Left (Load file) -> throwError $ Load file - _ -> do liftIO $ putStrLn "Continuing..." - put s { futharkiCount = futharkiCount s' - , futharkiSkipBreaks = futharkiSkipBreaks s' <> futharkiSkipBreaks s } - - c - -runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) -runInterpreter' m = runF m (return . Right) intOp - where intOp (I.ExtOpError err) = return $ Left err - intOp (I.ExtOpTrace w v c) = do - liftIO $ putStrLn $ "Trace at " ++ locStr w ++ ": " ++ v - c - intOp (I.ExtOpBreak _ _ _ c) = c - -type Command = T.Text -> FutharkiM () - -loadCommand :: Command -loadCommand file = do - loaded <- gets futharkiLoaded - case (T.null file, loaded) of - (True, Just loaded') -> throwError $ Load loaded' - (True, Nothing) -> liftIO $ T.putStrLn "No file specified and no file previously loaded." - (False, _) -> throwError $ Load $ T.unpack file - -typeCommand :: Command -typeCommand e = do - prompt <- getPrompt - case parseExp prompt e of - Left err -> liftIO $ print err - Right e' -> do - imports <- gets futharkiImports - src <- gets futharkiNameSource - (tenv, _) <- gets futharkiEnv - case T.checkExp imports src tenv e' of - Left err -> liftIO $ print err - Right (ps, e'') -> liftIO $ putStrLn $ - pretty e' <> concatMap ((" "<>) . pretty) ps <> - " : " <> pretty (typeOf e'') - -unbreakCommand :: Command -unbreakCommand _ = do - breaking <- gets futharkiBreaking - case breaking of - Nothing -> liftIO $ putStrLn "Not currently stopped at a breakpoint." - Just loc -> do modify $ \s -> s { futharkiSkipBreaks = loc : futharkiSkipBreaks s } - throwError Stop - -pwdCommand :: Command -pwdCommand _ = liftIO $ putStrLn =<< getCurrentDirectory - -cdCommand :: Command -cdCommand dir - | T.null dir = liftIO $ putStrLn "Usage: ':cd '." - | otherwise = - liftIO $ setCurrentDirectory (T.unpack dir) - `Haskeline.catch` \(err::IOException) -> print err - -helpCommand :: Command -helpCommand _ = liftIO $ forM_ commands $ \(cmd, (_, desc)) -> do - T.putStrLn $ ":" <> cmd - T.putStrLn $ T.replicate (1+T.length cmd) "-" - T.putStr desc - T.putStrLn "" - T.putStrLn "" - -quitCommand :: Command -quitCommand _ = throwError Exit - -commands :: [(T.Text, (Command, T.Text))] -commands = [("load", (loadCommand, [text| -Load a Futhark source file. Usage: - - > :load foo.fut - -If the loading succeeds, any subsequentialy entered expressions entered -subsequently will have access to the definition (such as function definitions) -in the source file. - -Only one source file can be loaded at a time. Using the :load command a -second time will replace the previously loaded file. It will also replace -any declarations entered at the REPL. - -|])), - ("type", (typeCommand, [text| -Show the type of an expression. -|])), - ("unbreak", (unbreakCommand, [text| -Skip all future occurences of the current breakpoint. -|])), - ("pwd", (pwdCommand, [text| -Print the current working directory. -|])), - ("cd", (cdCommand, [text| -Change the current working directory. -|])), - ("help", (helpCommand, [text| -Print a list of commands and a description of their behaviour. -|])), - ("quit", (quitCommand, [text| -Quit futharki. -|]))] +main = do + prog <- getProgName + args <- getArgs + let suffix = case args of + [] -> "repl" + _ -> "run" + hPutStrLn stderr $ + "'" ++ prog ++ "' is deprecated. Use '" ++ + unwords ["futhark", suffix] ++ "' instead." + (_, _, _, h) <- createProcess $ proc "futhark" $ suffix:args + exitWith =<< waitForProcess h diff --git a/src/wrapper.hs b/src/wrapper.hs new file mode 100644 --- /dev/null +++ b/src/wrapper.hs @@ -0,0 +1,29 @@ +-- Wrapper program that translates @futhark-foo@ to @futhark foo@; +-- using whichever @futhark@ binary is in the user's search path. + +module Main (main) where + +import Data.Maybe + +import System.Environment +import System.Process +import System.IO +import System.Exit + +nameChanges :: [(String, String)] +nameChanges = [ ("py", "python") + , ("cs", "csharp") + ] + +main :: IO () +main = do + prog <- getProgName + args <- getArgs + let suffix = drop 1 $ dropWhile (/='-') prog + suffix' = fromMaybe suffix $ lookup suffix nameChanges + + hPutStrLn stderr $ + prog ++ ": this command is deprecated. Use '" ++ + unwords ["futhark", suffix'] ++ "' instead." + (_, _, _, h) <- createProcess $ proc "futhark" $ suffix':args + exitWith =<< waitForProcess h