futhark 0.15.2 → 0.15.3

raw patch · 89 files changed

+1015/−697 lines, 89 files

Files

• docs/installation.rst +27/−7
• futhark.cabal +1/−1
• rts/c/opencl.h +72/−57
• src/Futhark/Analysis/AlgSimplify.hs +1/−1
• src/Futhark/Analysis/CallGraph.hs +6/−7
• src/Futhark/Analysis/HORepresentation/MapNest.hs +1/−1
• src/Futhark/Analysis/Metrics.hs +1/−1
• src/Futhark/Analysis/PrimExp/Convert.hs +2/−1
• src/Futhark/Analysis/Range.hs +1/−1
• src/Futhark/Analysis/ScalExp.hs +1/−1
• src/Futhark/Analysis/SymbolTable.hs +1/−1
• src/Futhark/CLI/Autotune.hs +1/−1
• src/Futhark/CLI/Bench.hs +1/−1
• src/Futhark/CLI/Dev.hs +3/−2
• src/Futhark/CLI/Doc.hs +1/−1
• src/Futhark/CLI/Pkg.hs +1/−1
• src/Futhark/CLI/REPL.hs +3/−3
• src/Futhark/CLI/Run.hs +1/−3
• src/Futhark/CLI/Test.hs +1/−2
• src/Futhark/CodeGen/Backends/CCUDA.hs +2/−3
• src/Futhark/CodeGen/Backends/COpenCL.hs +1/−1
• src/Futhark/CodeGen/Backends/CSOpenCL.hs +1/−2
• src/Futhark/CodeGen/Backends/GenericC.hs +26/−17
• src/Futhark/CodeGen/Backends/GenericCSharp.hs +1/−1
• src/Futhark/CodeGen/Backends/GenericPython.hs +1/−1
• src/Futhark/CodeGen/ImpCode.hs +1/−1
• src/Futhark/CodeGen/ImpCode/Kernels.hs +23/−32
• src/Futhark/CodeGen/ImpGen.hs +9/−5
• src/Futhark/CodeGen/ImpGen/Kernels.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +182/−136
• src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +3/−4
• src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +11/−11
• src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +77/−45
• src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +12/−18
• src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +2/−2
• src/Futhark/Compiler/Program.hs +1/−1
• src/Futhark/Construct.hs +1/−1
• src/Futhark/Internalise.hs +139/−131
• src/Futhark/Internalise/Defunctionalise.hs +2/−2
• src/Futhark/Internalise/Defunctorise.hs +10/−1
• src/Futhark/Internalise/Monomorphise.hs +6/−1
• src/Futhark/Internalise/TypesValues.hs +1/−1
• src/Futhark/Optimise/CSE.hs +8/−0
• src/Futhark/Optimise/DoubleBuffer.hs +1/−1
• src/Futhark/Optimise/Fusion/Composing.hs +1/−1
• src/Futhark/Optimise/Fusion/LoopKernel.hs +1/−1
• src/Futhark/Optimise/InliningDeadFun.hs +158/−78
• src/Futhark/Optimise/Simplify/Engine.hs +6/−1
• src/Futhark/Optimise/Simplify/Rules.hs +20/−8
• src/Futhark/Optimise/TileLoops.hs +1/−1
• src/Futhark/Pass/ExpandAllocations.hs +10/−8
• src/Futhark/Pass/ExplicitAllocations.hs +5/−6
• src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +1/−1
• src/Futhark/Pass/ExtractKernels/DistributeNests.hs +1/−1
• src/Futhark/Pass/ExtractKernels/Distribution.hs +1/−1
• src/Futhark/Pass/ExtractKernels/Interchange.hs +1/−1
• src/Futhark/Pass/KernelBabysitting.hs +1/−1
• src/Futhark/Passes.hs +4/−1
• src/Futhark/Pkg/Info.hs +30/−18
• src/Futhark/Pkg/Types.hs +1/−1
• src/Futhark/Representation/AST/Attributes.hs +3/−2
• src/Futhark/Representation/AST/Attributes/Ranges.hs +4/−0
• src/Futhark/Representation/AST/Attributes/Rearrange.hs +1/−1
• src/Futhark/Representation/AST/Pretty.hs +4/−2
• src/Futhark/Representation/AST/Syntax.hs +6/−1
• src/Futhark/Representation/ExplicitMemory.hs +1/−1
• src/Futhark/Representation/ExplicitMemory/IndexFunction.hs +1/−1
• src/Futhark/Representation/ExplicitMemory/Simplify.hs +1/−1
• src/Futhark/Representation/Kernels/Kernel.hs +1/−1
• src/Futhark/Representation/Kernels/Simplify.hs +1/−1
• src/Futhark/Representation/Primitive.hs +11/−5
• src/Futhark/Representation/SOACS/SOAC.hs +1/−1
• src/Futhark/Representation/SOACS/Simplify.hs +1/−1
• src/Futhark/Test.hs +1/−1
• src/Futhark/TypeCheck.hs +1/−1
• src/Futhark/Util.hs +7/−3
• src/Futhark/Util/Table.hs +1/−1
• src/Language/Futhark/Attributes.hs +1/−1
• src/Language/Futhark/Interpreter.hs +7/−2
• src/Language/Futhark/Pretty.hs +1/−1
• src/Language/Futhark/Syntax.hs +37/−18
• src/Language/Futhark/TypeChecker.hs +25/−2
• src/Language/Futhark/TypeChecker/Modules.hs +1/−1
• src/Language/Futhark/TypeChecker/Monad.hs +1/−1
• src/Language/Futhark/TypeChecker/Terms.hs +1/−1
• src/Language/Futhark/TypeChecker/Types.hs +1/−1
• src/Language/Futhark/TypeChecker/Unify.hs +2/−2
• src/Language/Futhark/Warnings.hs +1/−1
• src/futhark.hs +1/−1

@@ -28,12 +28,12 @@ Compiling from source --------------------- -We use the the `Haskell Tool Stack`_ to handle dependencies and-compilation of the Futhark compiler, so you will need to install the-``stack`` tool.  Fortunately, the ``stack`` developers provide ample-documentation about `installing Stack`_ on a multitude of operating-systems.  If you're lucky, it may even be in your local package-repository.+The recommended way to compile Futhark is with the `Haskell Tool+Stack`_, which handles dependencies and compilation of the Futhark+compiler.  You will therefore need to install the ``stack`` tool.+Fortunately, the ``stack`` developers provide ample documentation+about `installing Stack`_ on a multitude of operating systems.  If+you're lucky, it may even be in your local package repository.  You can either retrieve a `source release tarball <https://github.com/diku-dk/futhark/releases>`_ or perform a checkout@@ -70,6 +70,22 @@  Note that this does not install the Futhark manual pages. +Compiling with ``cabal``+~~~~~~~~~~~~~~~~~~~~~~~~++You can also compile Futhark with ``cabal``.  If so, you must install+an appropriate version of GHC and ``cabal`` yourself, for example+through your favourite package manager.  On Linux, you can always use+`ghcup <https://gitlab.haskell.org/haskell/ghcup>`_.  Then clone the+repository as listed above and run::++  $ cabal build++To install the Futhark binaries to a specific location, for example+``$HOME/.local/bin``, run::++  $ cabal install --install-method=copy  --overwrite-policy=always --installdir=$HOME/.local/bin/+ Installing from a precompiled snapshot -------------------------------------- @@ -115,7 +131,11 @@   be a bit behind.  * Arch Linux users can use a `futhark-nightly package-  <https://aur.archlinux.org/packages/futhark-nightly/>`_.+  <https://aur.archlinux.org/packages/futhark-nightly/>`_ or a+  `regular futhark package+  <https://aur.archlinux.org/packages/futhark>`_.++* NixOS users can install the ``futhark`` derivation.  Otherwise (or if the version in the package system is too old), your best bet is to install from source or use a tarball, as described

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:           futhark-version:        0.15.2+version:        0.15.3 synopsis:       An optimising compiler for a functional, array-oriented language. description:    Futhark is a small programming language designed to be compiled to                 efficient parallel code. It is a statically typed, data-parallel,

@@ -617,80 +617,57 @@   }    char *fut_opencl_src = NULL;-  size_t src_size = 0;--  // Maybe we have to read OpenCL source from somewhere else (used for debugging).-  if (ctx->cfg.load_program_from != NULL) {-    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++) {-      src_size += strlen(*src);-    }--    fut_opencl_src = (char*) malloc(src_size + 1);--    size_t n, i;-    for (i = 0, n = 0; srcs && srcs[i]; i++) {-      strncpy(fut_opencl_src+n, srcs[i], src_size-n);-      n += strlen(srcs[i]);-    }-    fut_opencl_src[src_size] = 0;--  }-   cl_program prog;   error = CL_SUCCESS;-  const char* src_ptr[] = {fut_opencl_src}; -  if (ctx->cfg.dump_program_to != NULL) {-    FILE *f = fopen(ctx->cfg.dump_program_to, "w");-    assert(f != NULL);-    fputs(fut_opencl_src, f);-    fclose(f);-  }-   if (ctx->cfg.load_binary_from == NULL) {-    prog = clCreateProgramWithSource(ctx->ctx, 1, src_ptr, &src_size, &error);-    OPENCL_SUCCEED_FATAL(error);+    size_t src_size = 0; -    int compile_opts_size = 1024;+    // Maybe we have to read OpenCL source from somewhere else (used for debugging).+    if (ctx->cfg.load_program_from != NULL) {+      fut_opencl_src = slurp_file(ctx->cfg.load_program_from, NULL);+      assert(fut_opencl_src != NULL);+    } else if (ctx->cfg.load_binary_from == NULL) {+      // Construct the OpenCL source concatenating all the fragments.+      for (const char **src = srcs; src && *src; src++) {+        src_size += strlen(*src);+      } -    for (int i = 0; i < ctx->cfg.num_sizes; i++) {-      compile_opts_size += strlen(ctx->cfg.size_names[i]) + 20;-    }+      fut_opencl_src = (char*) malloc(src_size + 1); -    for (int i = 0; extra_build_opts[i] != NULL; i++) {-      compile_opts_size += strlen(extra_build_opts[i] + 1);+      size_t n, i;+      for (i = 0, n = 0; srcs && srcs[i]; i++) {+        strncpy(fut_opencl_src+n, srcs[i], src_size-n);+        n += strlen(srcs[i]);+      }+      fut_opencl_src[src_size] = 0;     } -    char *compile_opts = (char*) malloc(compile_opts_size);--    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_vars[i],-                    (int)ctx->cfg.size_values[i]);+    if (ctx->cfg.dump_program_to != NULL) {+      if (ctx->cfg.debugging) {+        fprintf(stderr, "Dumping OpenCL source to %s...\n", ctx->cfg.dump_program_to);+      }+      FILE *f = fopen(ctx->cfg.dump_program_to, "w");+      assert(f != NULL);+      fputs(fut_opencl_src, f);+      fclose(f);     } -    for (int i = 0; extra_build_opts[i] != NULL; i++) {-      w += snprintf(compile_opts+w, compile_opts_size-w,-                    "%s ", extra_build_opts[i]);+    if (ctx->cfg.debugging) {+      fprintf(stderr, "Creating OpenCL program...\n");     } -    OPENCL_SUCCEED_FATAL(build_opencl_program(prog, device_option.device, compile_opts));--    free(compile_opts);+    const char* src_ptr[] = {fut_opencl_src};+    prog = clCreateProgramWithSource(ctx->ctx, 1, src_ptr, &src_size, &error);+    OPENCL_SUCCEED_FATAL(error);   } else {+    if (ctx->cfg.debugging) {+      fprintf(stderr, "Loading OpenCL binary from %s...\n", ctx->cfg.load_binary_from);+    }     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);+    assert(fut_opencl_bin != NULL);     const unsigned char *binaries[1] = { fut_opencl_bin };     cl_int status = 0; @@ -702,9 +679,47 @@     OPENCL_SUCCEED_FATAL(error);   } +  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;+  }++  for (int i = 0; extra_build_opts[i] != NULL; i++) {+    compile_opts_size += strlen(extra_build_opts[i] + 1);+  }++  char *compile_opts = (char*) malloc(compile_opts_size);++  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_vars[i],+                  (int)ctx->cfg.size_values[i]);+  }++  for (int i = 0; extra_build_opts[i] != NULL; i++) {+    w += snprintf(compile_opts+w, compile_opts_size-w,+                  "%s ", extra_build_opts[i]);+  }++  if (ctx->cfg.debugging) {+    fprintf(stderr, "Building OpenCL program...\n");+  }+  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) {+    if (ctx->cfg.debugging) {+      fprintf(stderr, "Dumping OpenCL binary to %s...\n", ctx->cfg.dump_binary_to);+    }+     size_t binary_size;     OPENCL_SUCCEED_FATAL(clGetProgramInfo(prog, CL_PROGRAM_BINARY_SIZES,                                           sizeof(size_t), &binary_size, NULL));

@@ -13,7 +13,7 @@  import qualified Data.Set as S import qualified Data.Map.Strict as M-import Data.List+import Data.List (sort, sortBy, genericReplicate) import Control.Monad import Control.Monad.Reader import Control.Monad.State

@@ -8,9 +8,8 @@  import Control.Monad.Writer.Strict import qualified Data.Map.Strict as M-import qualified Data.Set as S import Data.Maybe (isJust)-import Data.List+import Data.List (foldl')  import Futhark.Representation.SOACS @@ -23,7 +22,7 @@ -- | The call graph is just a mapping from a function name, i.e., the -- caller, to a set of the names of functions called *directly* (not -- transitively!) by the function.-type CallGraph = M.Map Name (S.Set Name)+type CallGraph = M.Map Name (M.Map Name ConstFun)  -- | @buildCallGraph prog@ build the program's call graph. buildCallGraph :: Prog SOACS -> CallGraph@@ -43,14 +42,14 @@                let callees = buildCGbody $ funDefBody f                    cg' = M.insert fname callees cg                -- recursively build the callees-               foldl' (buildCGfun ftable) cg' callees+               foldl' (buildCGfun ftable) cg' $ M.keys callees     _ -> cg -buildCGbody :: Body -> S.Set Name+buildCGbody :: Body -> M.Map Name ConstFun buildCGbody = mconcat . map (buildCGexp . stmExp) . stmsToList . bodyStms -buildCGexp :: Exp -> S.Set Name-buildCGexp (Apply fname _ _ _) = S.singleton fname+buildCGexp :: Exp -> M.Map Name ConstFun+buildCGexp (Apply fname _ _ (constf, _, _, _)) = M.singleton fname constf buildCGexp (Op op) = execWriter $ mapSOACM folder op   where folder = identitySOACMapper {           mapOnSOACLambda = \lam -> do tell $ buildCGbody $ lambdaBody lam

@@ -13,7 +13,7 @@   ) where -import Data.List+import Data.List (find) import Data.Maybe import qualified Data.Map.Strict as M 

@@ -20,7 +20,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.String-import Data.List+import Data.List (tails) import qualified Data.Map.Strict as M  import Futhark.Representation.AST

@@ -44,7 +44,8 @@ primExpToExp _ (ValueExp v) =   return $ BasicOp $ SubExp $ Constant v primExpToExp f (FunExp h args t) =-  Apply (nameFromString h) <$> args' <*> pure [primRetType t] <*> pure (Safe, noLoc, [])+  Apply (nameFromString h) <$> args' <*> pure [primRetType t] <*>+  pure (NotConstFun, Safe, noLoc, [])   where args' = zip <$> mapM (primExpToSubExp "apply_arg" f) args <*> pure (repeat Observe) primExpToExp f (LeafExp v _) =   f v

@@ -13,7 +13,7 @@  import qualified Data.Map.Strict as M import Control.Monad.Reader-import Data.List+import Data.List (nub)  import qualified Futhark.Analysis.ScalExp as SE import Futhark.Representation.Ranges

@@ -12,7 +12,7 @@   ) where -import Data.List+import Data.List (find) import Data.Maybe  import Futhark.Representation.Primitive hiding (SQuot, SRem, SDiv, SMod, SSignum)

@@ -56,7 +56,7 @@ import Control.Monad.Reader import Data.Ord import Data.Maybe-import Data.List hiding (elem, lookup)+import Data.List (foldl', elemIndex) import qualified Data.List as L import qualified Data.Set        as S import qualified Data.Map.Strict as M

@@ -6,7 +6,7 @@ import qualified Data.ByteString.Char8 as SBS import Data.Time.Clock.POSIX import Data.Tree-import Data.List+import Data.List (intersect, isPrefixOf, foldl', sort, sortOn) import Data.Maybe import Text.Read (readMaybe) import Text.Regex.TDFA

@@ -11,7 +11,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Either import Data.Maybe-import Data.List+import Data.List (foldl', sortBy) import Data.Ord import qualified Data.Text as T import System.Console.GetOpt

@@ -3,7 +3,7 @@ module Futhark.CLI.Dev (main) where  import Data.Maybe-import Data.List+import Data.List (intersperse) import Control.Category (id) import Control.Monad import Control.Monad.State@@ -298,7 +298,8 @@     "Ignore 'unsafe'."   , typedPassOption soacsProg Kernels firstOrderTransform "f"   , soacsPassOption fuseSOACs "o"-  , soacsPassOption inlineAndRemoveDeadFunctions []+  , soacsPassOption inlineFunctions []+  , soacsPassOption inlineConstants []   , kernelsPassOption inPlaceLowering []   , kernelsPassOption babysitKernels []   , kernelsPassOption tileLoops []

@@ -6,7 +6,7 @@  import Control.Monad.State import Data.FileEmbed-import Data.List+import Data.List (nubBy) import System.FilePath import System.Directory (createDirectoryIfMissing) import System.Console.GetOpt

@@ -10,7 +10,7 @@ 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.List (isPrefixOf, intercalate) import Data.Monoid import System.Directory import System.FilePath

@@ -8,7 +8,7 @@ import Control.Monad.Free.Church import Control.Exception import Data.Char-import Data.List+import Data.List (intercalate, intersperse) import Data.Loc import Data.Maybe import Data.Version@@ -156,7 +156,7 @@       (ws, imports, src) <-         badOnLeft show =<<         liftIO (runExceptT (readProgram file)-                 `Haskeline.catch` \(err::IOException) ->+                 `catch` \(err::IOException) ->                    return (externalErrorS (show err)))       liftIO $ hPrint stderr ws @@ -411,7 +411,7 @@  | T.null dir = liftIO $ putStrLn "Usage: ':cd <dir>'."  | otherwise =     liftIO $ setCurrentDirectory (T.unpack dir)-    `Haskeline.catch` \(err::IOException) -> print err+    `catch` \(err::IOException) -> print err  helpCommand :: Command helpCommand _ = liftIO $ forM_ commands $ \(cmd, (_, desc)) -> do

@@ -5,7 +5,6 @@  import Control.Monad.Free.Church import Control.Exception-import Data.List import Data.Loc import Data.Maybe import qualified Data.Map as M@@ -17,7 +16,6 @@ import System.Exit import System.Console.GetOpt import System.IO-import qualified System.Console.Haskeline as Haskeline  import Prelude @@ -106,7 +104,7 @@   (ws, imports, src) <-     badOnLeft show =<<     liftIO (runExceptT (readProgram file)-            `Haskeline.catch` \(err::IOException) ->+            `catch` \(err::IOException) ->                return (externalErrorS (show err)))   when (interpreterPrintWarnings cfg) $     liftIO $ hPrint stderr ws

@@ -11,8 +11,7 @@ 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.List (delete, partition) import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.Encoding as T

@@ -8,7 +8,8 @@   ) where  import Control.Monad-import Data.List+import Data.List (intercalate)+import Data.Maybe (catMaybes) import qualified Language.C.Quote.OpenCL as C  import qualified Futhark.CodeGen.Backends.GenericC as GC@@ -20,8 +21,6 @@ import Futhark.CodeGen.Backends.COpenCL.Boilerplate (commonOptions) 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

@@ -7,7 +7,7 @@   ) where  import Control.Monad hiding (mapM)-import Data.List+import Data.List (intercalate) import qualified Data.Map as M  import qualified Language.C.Syntax as C

@@ -4,8 +4,7 @@   ) where  import Control.Monad-import Data.List-+import Data.List (intersperse)  import Futhark.Error import Futhark.Representation.ExplicitMemory (Prog, ExplicitMemory, int32)

@@ -72,7 +72,7 @@ import Data.Char (ord, isDigit, isAlphaNum) import qualified Data.Map.Strict as M import qualified Data.DList as DL-import Data.List+import Data.List (unzip4) import Data.Loc import Data.Maybe import Data.FileEmbed@@ -360,6 +360,10 @@ item :: C.BlockItem -> CompilerM op s () item x = tell $ mempty { accItems = DL.singleton x } +fatMemory :: Space -> CompilerM op s Bool+fatMemory ScalarSpace{} = return False+fatMemory _ = asks envFatMemory+ instance C.ToIdent Name where   toIdent = C.toIdent . zEncodeString . nameToString @@ -455,7 +459,7 @@  memToCType :: Space -> CompilerM op s C.Type memToCType space = do-  refcount <- asks envFatMemory+  refcount <- fatMemory space   if refcount      then return $ fatMemType space      else rawMemCType space@@ -466,8 +470,8 @@ rawMemCType (ScalarSpace [] t) =   return [C.cty|$ty:(primTypeToCType t)[1]|] rawMemCType (ScalarSpace ds t) =-  return $ foldl' addDim [C.cty|$ty:(primTypeToCType t)|] ds-  where addDim t' d = [C.cty|$ty:t'[$exp:d]|]+  return [C.cty|$ty:(primTypeToCType t)[$exp:(cproduct ds')]|]+  where ds' = map (`C.toExp` noLoc) ds  fatMemType :: Space -> C.Type fatMemType space =@@ -605,18 +609,18 @@ declMem name space = do   ty <- memToCType space   decl [C.cdecl|$ty:ty $id:name;|]-  resetMem name+  resetMem name space   modify $ \s -> s { compDeclaredMem = (name, space) : compDeclaredMem s } -resetMem :: C.ToExp a => a -> CompilerM op s ()-resetMem mem = do-  refcount <- asks envFatMemory+resetMem :: C.ToExp a => a -> Space -> CompilerM op s ()+resetMem mem space = do+  refcount <- fatMemory space   when refcount $     stm [C.cstm|$exp:mem.references = NULL;|]  setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> CompilerM op s () setMem dest src space = do-  refcount <- asks envFatMemory+  refcount <- fatMemory space   let src_s = pretty $ C.toExp src noLoc   if refcount     then stm [C.cstm|if ($id:(fatMemSet space)(ctx, &$exp:dest, &$exp:src,@@ -627,7 +631,7 @@  unRefMem :: C.ToExp a => a -> Space -> CompilerM op s () unRefMem mem space = do-  refcount <- asks envFatMemory+  refcount <- fatMemory space   let mem_s = pretty $ C.toExp mem noLoc   when refcount $     stm [C.cstm|if ($id:(fatMemUnRef space)(ctx, &$exp:mem, $string:mem_s) != 0) {@@ -637,7 +641,7 @@ allocMem :: (C.ToExp a, C.ToExp b) =>             a -> b -> Space -> C.Stm -> CompilerM op s () allocMem name size space on_failure = do-  refcount <- asks envFatMemory+  refcount <- fatMemory space   let name_s = pretty $ C.toExp name noLoc   if refcount     then stm [C.cstm|if ($id:(fatMemAlloc space)(ctx, &$exp:name, $exp:size,@@ -737,7 +741,7 @@   memty <- rawMemCType space    let prepare_new = do-        resetMem [C.cexp|arr->mem|]+        resetMem [C.cexp|arr->mem|] space         allocMem [C.cexp|arr->mem|] [C.cexp|((size_t)$exp:arr_size) * sizeof($ty:pt')|] space                  [C.cstm|return NULL;|]         forM_ [0..rank-1] $ \i ->@@ -1401,6 +1405,8 @@  $esc:values_h +$esc:("#define __private")+ static int binary_output = 0; static typename FILE *runtime_file; static int perform_warmup = 0;@@ -1655,9 +1661,8 @@           <*> pure (primTypeToCType restype) <*> pure space <*> pure vol          compileLeaf (Index src (Count iexp) _ ScalarSpace{} _) = do-          src' <- rawMem src           iexp' <- compileExp iexp-          return [C.cexp|$exp:src'[$exp:iexp']|]+          return [C.cexp|$id:src[$exp:iexp']|]          compileLeaf (SizeOf t) =           return [C.cexp|(typename int32_t)sizeof($ty:t')|]@@ -1789,6 +1794,11 @@   stm [C.cstm|if (!$exp:e') { $items:err }|]   where stacktrace = prettyStacktrace 0 $ map locStr $ loc:locs +compileCode (Allocate _ _ ScalarSpace{}) =+  -- Handled by the declaration of the memory block, which is+  -- translated to an actual array.+  return ()+ compileCode (Allocate name (Count e) space) = do   size <- compileExp e   allocMem name size space [C.cstm|return 1;|]@@ -1850,10 +1860,9 @@   stm [C.cstm|$exp:deref = $exp:elemexp';|]  compileCode (Write dest (Count idx) _ ScalarSpace{} _ elemexp) = do-  dest' <- rawMem dest   idx' <- compileExp idx   elemexp' <- compileExp elemexp-  stm [C.cstm|$exp:dest'[$exp:idx'] = $exp:elemexp';|]+  stm [C.cstm|$id:dest[$exp:idx'] = $exp:elemexp';|]  compileCode (Write dest (Count idx) elemtype (Space space) vol elemexp) =   join $ asks envWriteScalar@@ -1950,7 +1959,7 @@           decl [C.cdecl|$ty:ctp $id:name;|]          setRetVal' p (MemParam name space) = do-          resetMem [C.cexp|*$exp:p|]+          resetMem [C.cexp|*$exp:p|] space           setMem [C.cexp|*$exp:p|] name space         setRetVal' p (ScalarParam name _) =           stm [C.cstm|*$exp:p = $id:name;|]

@@ -1295,7 +1295,7 @@ compileCode (Imp.Allocate name (Imp.Count e) _) = do   e' <- compileExp e   let allocate' = simpleCall "allocateMem" [e']-  let name' = Var (compileName name)+      name' = Var (compileName name)   stm $ Reassign name' allocate'  compileCode (Imp.Free name space) = do

@@ -939,7 +939,7 @@ compileCode (Imp.Allocate name (Imp.Count e) _) = do   e' <- compileExp e   let allocate' = simpleCall "allocateMem" [e']-  let name' = Var (compileName name)+      name' = Var (compileName name)   stm $ Assign name' allocate'  compileCode (Imp.Free name _) =

@@ -51,7 +51,7 @@   )   where -import Data.List+import Data.List (intersperse) import Data.Loc import Data.Traversable 

@@ -11,20 +11,17 @@   , KernelConstExp   , HostOp (..)   , KernelOp (..)+  , Fence (..)   , AtomicOp (..)   , Kernel (..)   , KernelUse (..)   , module Futhark.CodeGen.ImpCode   , module Futhark.Representation.Kernels.Sizes   -- * Utility functions-  , getKernels   , atomicBinOp   )   where -import Control.Monad.Writer-import Data.List- import Futhark.CodeGen.ImpCode hiding (Function, Code) import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.Representation.Kernels.Sizes@@ -80,14 +77,6 @@                | ConstUse VName KernelConstExp                  deriving (Eq, Show) -getKernels :: Program -> [Kernel]-getKernels = nubBy sameKernel . execWriter . traverse getFunKernels-  where getFunKernels (CallKernel kernel) =-          tell [kernel]-        getFunKernels _ =-          return ()-        sameKernel _ _ = False- -- | Get an atomic operator corresponding to a binary operator. atomicBinOp :: BinOp -> Maybe (VName -> VName -> Count Elements Imp.Exp -> Exp -> AtomicOp) atomicBinOp = flip lookup [ (Add Int32, AtomicAdd)@@ -147,6 +136,11 @@      text "failure_tolerant" <+> ppr (kernelFailureTolerant kernel) </>      text "body" <+> brace (ppr $ kernelBody kernel)) +-- | When we do a barrier or fence, is it at the local or global+-- level?+data Fence = FenceLocal | FenceGlobal+           deriving (Show)+ data KernelOp = GetGroupId VName Int               | GetLocalId VName Int               | GetLocalSize VName Int@@ -154,19 +148,16 @@               | GetGlobalId VName Int               | GetLockstepWidth VName               | Atomic Space AtomicOp-              | LocalBarrier-              | GlobalBarrier-              | MemFenceLocal-              | MemFenceGlobal-              | PrivateAlloc VName (Count Bytes Imp.Exp)+              | Barrier Fence+              | MemFence Fence               | LocalAlloc VName (Count Bytes Imp.Exp)-              | ErrorSync-                -- ^ Perform a local memory barrier and also check-                -- whether any threads have failed an assertion.  Make-                -- sure all threads would reach all 'ErrorSync's if-                -- any of them do.  A failing assertion will jump to-                -- the next following 'ErrorSync', so make sure it's-                -- not inside control flow or similar.+              | ErrorSync Fence+                -- ^ Perform a barrier and also check whether any+                -- threads have failed an assertion.  Make sure all+                -- threads would reach all 'ErrorSync's if any of them+                -- do.  A failing assertion will jump to the next+                -- following 'ErrorSync', so make sure it's not inside+                -- control flow or similar.               deriving (Show)  -- Atomic operations return the value stored before the update.@@ -214,20 +205,20 @@   ppr (GetLockstepWidth dest) =     ppr dest <+> text "<-" <+>     text "get_lockstep_width()"-  ppr LocalBarrier =+  ppr (Barrier FenceLocal) =     text "local_barrier()"-  ppr GlobalBarrier =+  ppr (Barrier FenceGlobal) =     text "global_barrier()"-  ppr MemFenceLocal =+  ppr (MemFence FenceLocal) =     text "mem_fence_local()"-  ppr MemFenceGlobal =+  ppr (MemFence FenceGlobal) =     text "mem_fence_global()"-  ppr (PrivateAlloc name size) =-    ppr name <+> equals <+> text "private_alloc" <> parens (ppr size)   ppr (LocalAlloc name size) =     ppr name <+> equals <+> text "local_alloc" <> parens (ppr size)-  ppr ErrorSync =-    text "error_sync()"+  ppr (ErrorSync FenceLocal) =+    text "error_sync_local()"+  ppr (ErrorSync FenceGlobal) =+    text "error_sync_global()"   ppr (Atomic _ (AtomicAdd old arr ind x)) =     ppr old <+> text "<-" <+> text "atomic_add" <>     parens (commasep [ppr arr <> brackets (ppr ind), ppr x])

@@ -88,7 +88,7 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe-import Data.List+import Data.List (find, sortOn)  import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.CodeGen.ImpCode@@ -957,16 +957,20 @@       IxFun.linearWithOffset srcIxFun bt_size = do         srcspace <- entryMemSpace <$> lookupMemory srcmem         destspace <- entryMemSpace <$> lookupMemory destmem-        emit $ Imp.Copy-          destmem (bytes destoffset) destspace-          srcmem (bytes srcoffset) srcspace $-          num_elems `withElemType` bt+        if isScalarSpace srcspace || isScalarSpace destspace+          then copyElementWise bt dest src+          else emit $ Imp.Copy+               destmem (bytes destoffset) destspace+               srcmem (bytes srcoffset) srcspace $+               num_elems `withElemType` bt   | otherwise =       copyElementWise bt dest src   where bt_size = primByteSize bt         num_elems = Imp.elements $ product $ map (toExp' int32) srcshape         MemLocation destmem _ destIxFun = dest         MemLocation srcmem srcshape srcIxFun = src+        isScalarSpace ScalarSpace{} = True+        isScalarSpace _ = False  copyElementWise :: CopyCompiler lore op copyElementWise bt dest src = do

@@ -10,7 +10,7 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Maybe-import Data.List+import Data.List ()  import Prelude hiding (quot) 

@@ -12,7 +12,6 @@   , isActive   , sKernelThread   , sKernelGroup-  , sKernelSimple   , sReplicate   , sIota   , sCopy@@ -23,9 +22,6 @@   , kernelLoop   , groupCoverSpace -  , getSize--  , atomicUpdate   , atomicUpdateLocking   , Locking(..)   , AtomicUpdate(..)@@ -37,7 +33,7 @@ import Control.Monad.Reader import Data.Maybe import qualified Data.Map.Strict as M-import Data.List+import Data.List (elemIndex, find, nub, zip4)  import Prelude hiding (quot, rem) @@ -72,11 +68,9 @@ keyWithEntryPoint fname key =   nameFromString $ nameToString fname ++ "." ++ nameToString key -allocLocal, allocPrivate :: AllocCompiler ExplicitMemory Imp.KernelOp+allocLocal :: AllocCompiler ExplicitMemory Imp.KernelOp allocLocal mem size =   sOp $ Imp.LocalAlloc mem size-allocPrivate mem size =-  sOp $ Imp.PrivateAlloc mem size  kernelAlloc :: KernelConstants             -> Pattern ExplicitMemory@@ -86,9 +80,6 @@   -- Handled by the declaration of the memory block, which is then   -- translated to an actual scalar variable during C code generation.   return ()-kernelAlloc _ (Pattern _ [mem]) size (Space "private") = do-  size' <- toExp size-  allocPrivate (patElemName mem) $ Imp.bytes size' kernelAlloc _ (Pattern _ [mem]) size (Space "local") = do   size' <- toExp size   allocLocal (patElemName mem) $ Imp.bytes size'@@ -161,15 +152,15 @@   copyDWIMFix (patElemName dest) [fromIntegral (i::Int32)] e [] compileGroupExp constants (Pattern _ [dest]) (BasicOp (Copy arr)) = do   groupCopy constants (patElemName dest) [] (Var arr) []-  sOp Imp.LocalBarrier+  sOp $ Imp.Barrier Imp.FenceLocal compileGroupExp constants (Pattern _ [dest]) (BasicOp (Manifest _ arr)) = do   groupCopy constants (patElemName dest) [] (Var arr) []-  sOp Imp.LocalBarrier+  sOp $ Imp.Barrier Imp.FenceLocal compileGroupExp constants (Pattern _ [dest]) (BasicOp (Replicate ds se)) = do   ds' <- mapM toExp $ shapeDims ds   groupCoverSpace constants ds' $ \is ->     copyDWIMFix (patElemName dest) is se (drop (shapeRank ds) is)-  sOp Imp.LocalBarrier+  sOp $ Imp.Barrier Imp.FenceLocal compileGroupExp constants (Pattern _ [dest]) (BasicOp (Iota n e s _)) = do   n' <- toExp n   e' <- toExp e@@ -177,7 +168,7 @@   groupLoop constants n' $ \i' -> do     x <- dPrimV "x" $ e' + i' * s'     copyDWIMFix (patElemName dest) [i'] (Var x) []-  sOp Imp.LocalBarrier+  sOp $ Imp.Barrier Imp.FenceLocal  compileGroupExp _ dest e =   defCompileExp dest e@@ -250,7 +241,7 @@     zipWithM_ (compileThreadResult space constants) (patternElements pat) $     kernelBodyResult body -  sOp Imp.ErrorSync+  sOp $ Imp.ErrorSync Imp.FenceLocal  compileGroupOp constants pat (Inner (SegOp (SegScan lvl space scan_op _ _ body))) = do   compileGroupSpace constants lvl space@@ -264,11 +255,11 @@     (map (`Imp.var` int32) ltids)     (kernelResultSubExp res) [] -  sOp Imp.ErrorSync+  sOp $ Imp.ErrorSync Imp.FenceLocal    let segment_size = last dims'       crossesSegment from to = (to-from) .>. (to `rem` segment_size)-  groupScan constants (Just crossesSegment) (product dims') scan_op $+  groupScan constants (Just crossesSegment) (product dims') (product dims') scan_op $     patternNames pat  compileGroupOp constants pat (Inner (SegOp (SegRed lvl space ops _ body))) = do@@ -293,7 +284,7 @@       copyDWIMFix dest (map (`Imp.var` int32) ltids) (kernelResultSubExp res) []     zipWithM_ (compileThreadResult space constants) map_pes map_res -  sOp Imp.ErrorSync+  sOp $ Imp.ErrorSync Imp.FenceLocal    case dims' of     -- Nonsegmented case (or rather, a single segment) - this we can@@ -302,7 +293,7 @@       forM_ (zip ops tmps_for_ops) $ \(op, tmps) ->         groupReduce constants dim' (segRedLambda op) tmps -      sOp Imp.ErrorSync+      sOp $ Imp.ErrorSync Imp.FenceLocal        forM_ (zip red_pes tmp_arrs) $ \(pe, arr) ->         copyDWIMFix (patElemName pe) [] (Var arr) [0]@@ -315,15 +306,16 @@           crossesSegment from to = (to-from) .>. (to `rem` segment_size)        forM_ (zip ops tmps_for_ops) $ \(op, tmps) ->-        groupScan constants (Just crossesSegment) (product dims') (segRedLambda op) tmps+        groupScan constants (Just crossesSegment) (product dims') (product dims')+        (segRedLambda op) tmps -      sOp Imp.ErrorSync+      sOp $ Imp.ErrorSync Imp.FenceLocal        let segment_is = map Imp.vi32 $ init ltids       forM_ (zip red_pes tmp_arrs) $ \(pe, arr) ->         copyDWIMFix (patElemName pe) segment_is (Var arr) (segment_is ++ [last dims'-1]) -      sOp Imp.LocalBarrier+      sOp $ Imp.Barrier Imp.FenceLocal  compileGroupOp constants pat (Inner (SegOp (SegHist lvl space ops _ kbody))) = do   compileGroupSpace constants lvl space@@ -339,7 +331,7 @@   ops' <- prepareIntraGroupSegHist constants (segGroupSize lvl) ops    -- Ensure that all locks have been initialised.-  sOp Imp.LocalBarrier+  sOp $ Imp.Barrier Imp.FenceLocal    sWhen (isActive $ unSegSpace space) $     compileStms mempty (kernelBodyStms kbody) $ do@@ -365,7 +357,7 @@               copyDWIMFix (paramName p) [] v is             do_op (bin_is ++ is) -  sOp Imp.ErrorSync+  sOp $ Imp.ErrorSync Imp.FenceLocal  compileGroupOp _ pat _ =   compilerBugS $ "compileGroupOp: cannot compile rhs of binding " ++ pretty pat@@ -410,15 +402,6 @@   | AtomicLocking (Locking -> DoAtomicUpdate lore)     -- ^ Requires explicit locking. -atomicUpdate :: ExplicitMemorish lore =>-                Space -> [VName] -> [Imp.Exp] -> Lambda lore -> Locking-             -> ImpM lore Imp.KernelOp ()-atomicUpdate space arrs bucket lam locking =-  case atomicUpdateLocking lam of-    AtomicPrim f -> f space arrs bucket-    AtomicCAS f -> f space arrs bucket-    AtomicLocking f -> f locking space arrs bucket- -- | 'atomicUpdate', but where it is explicitly visible whether a -- locking strategy is necessary. atomicUpdateLocking :: ExplicitMemorish lore =>@@ -506,8 +489,8 @@         sComment "update global result" $         zipWithM_ (writeArray bucket) arrs $ map (Var . paramName) acc_params -      fence = case space of Space "local" -> sOp Imp.MemFenceLocal-                            _             -> sOp Imp.MemFenceGlobal+      fence = case space of Space "local" -> sOp $ Imp.MemFence Imp.FenceLocal+                            _             -> sOp $ Imp.MemFence Imp.FenceGlobal     -- While-loop: Try to insert your value@@ -712,16 +695,6 @@         globalMemory entry =           entry -writeParamToLocalMemory :: Imp.Exp -> VName -> LParam ExplicitMemory-                        -> ImpM lore op ()-writeParamToLocalMemory i arr param =-  everythingVolatile $ copyDWIM arr [DimFix i] (Var $ paramName param) []--readParamFromLocalMemory :: Imp.Exp -> LParam ExplicitMemory -> VName-                         -> ImpM lore op ()-readParamFromLocalMemory i param arr =-  everythingVolatile $ copyDWIM (paramName param) [] (Var arr) [DimFix i]- groupReduce :: ExplicitMemorish lore =>                KernelConstants             -> Imp.Exp@@ -800,8 +773,8 @@         global_tid = kernelGlobalThreadId constants          barrier-          | all primType $ lambdaReturnType lam = sOp Imp.LocalBarrier-          | otherwise                           = sOp Imp.GlobalBarrier+          | all primType $ lambdaReturnType lam = sOp $ Imp.Barrier Imp.FenceLocal+          | otherwise                           = sOp $ Imp.Barrier Imp.FenceGlobal          readReduceArgument param arr           | Prim _ <- paramType param = do@@ -820,13 +793,11 @@ groupScan :: KernelConstants           -> Maybe (Imp.Exp -> Imp.Exp -> Imp.Exp)           -> Imp.Exp+          -> Imp.Exp           -> Lambda ExplicitMemory           -> [VName]           -> ImpM ExplicitMemory Imp.KernelOp ()-groupScan constants seg_flag w lam arrs = do-  unless (all (primType . paramType) $ lambdaParams lam) $-    compilerLimitationS "Cannot compile parallel scans with array element type."-+groupScan constants seg_flag arrs_full_size w lam arrs = do   renamed_lam <- renameLambda lam    let ltid = kernelLocalThreadId constants@@ -848,117 +819,196 @@       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 arrs+      doInBlockScan seg_flag' active =+        inBlockScan constants seg_flag' arrs_full_size+        simd_width block_size active arrs barrier       ltid_in_bounds = ltid .<. w+      array_scan = not $ all primType $ lambdaReturnType lam+      barrier | array_scan =+                  sOp $ Imp.Barrier Imp.FenceGlobal+              | otherwise =+                  sOp $ Imp.Barrier Imp.FenceLocal +      group_offset = kernelGroupId constants * kernelGroupSize constants++      writeBlockResult p arr+        | primType $ paramType p =+            copyDWIM arr [DimFix block_id] (Var $ paramName p) []+        | otherwise =+            copyDWIM arr [DimFix $ group_offset + block_id] (Var $ paramName p) []++      readPrevBlockResult p arr+        | primType $ paramType p =+            copyDWIM (paramName p) [] (Var arr) [DimFix $ block_id - 1]+        | otherwise =+            copyDWIM (paramName p) [] (Var arr) [DimFix $ group_offset + block_id - 1]+   doInBlockScan seg_flag ltid_in_bounds lam-  sOp Imp.LocalBarrier+  barrier +  let is_first_block = block_id .==. 0+  when array_scan $ do+    sComment "save correct values for first block" $+      sWhen is_first_block $ forM_ (zip x_params arrs) $ \(x, arr) ->+      unless (primType $ paramType x) $+      copyDWIM arr [DimFix $ arrs_full_size + group_offset + block_size + ltid] (Var $ paramName x) []++    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 .&&. ltid_in_bounds) $-    zipWithM_ (writeParamToLocalMemory block_id) arrs y_params+    sWhen (last_in_block .&&. ltid_in_bounds) $ everythingVolatile $+    zipWithM_ writeBlockResult x_params arrs -  sOp Imp.LocalBarrier+  barrier -  let is_first_block = block_id .==. 0-      first_block_seg_flag = do+  let 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)   comment-    "scan the first block, after which offset 'i' contains carry-in for warp 'i+1'" $+    "scan the first block, after which offset 'i' contains carry-in for block 'i+1'" $     doInBlockScan first_block_seg_flag (is_first_block .&&. ltid_in_bounds) renamed_lam -  sOp Imp.LocalBarrier+  barrier -  let read_carry_in =-        zipWithM_ (readParamFromLocalMemory (block_id - 1))-        x_params arrs+  when array_scan $ do+    sComment "move correct values for first block back a block" $+      sWhen is_first_block $ forM_ (zip x_params arrs) $ \(x, arr) ->+      unless (primType $ paramType x) $+      copyDWIM+      arr [DimFix $ arrs_full_size + group_offset + ltid]+      (Var arr) [DimFix $ arrs_full_size + group_offset + block_size + ltid] -  let op_to_y+    barrier++  let read_carry_in = do+        forM_ (zip x_params y_params) $ \(x,y) ->+          copyDWIM (paramName y) [] (Var (paramName x)) []+        zipWithM_ readPrevBlockResult x_params arrs++      y_to_x = forM_ (zip x_params y_params) $ \(x,y) ->+        when (primType (paramType x)) $+        copyDWIM (paramName x) [] (Var (paramName y)) []++      op_to_x         | Nothing <- seg_flag =-            compileBody' y_params $ lambdaBody lam-        | Just flag_true <- seg_flag =-            sUnless (flag_true (block_id*block_size-1) ltid) $-              compileBody' y_params $ lambdaBody lam+            compileBody' x_params $ lambdaBody lam+        | Just flag_true <- seg_flag = do+            inactive <-+              dPrimVE "inactive" $ flag_true (block_id*block_size-1) ltid+            sWhen inactive y_to_x+            when array_scan barrier+            sUnless inactive $ compileBody' x_params $ lambdaBody lam+       write_final_result =-        zipWithM_ (writeParamToLocalMemory ltid) arrs y_params+        forM_ (zip x_params arrs) $ \(p, arr) ->+        when (primType $ paramType p) $+        copyDWIM arr [DimFix ltid] (Var $ paramName p) []    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 "perform operation" op_to_x     sComment "write final result" write_final_result -  sOp Imp.LocalBarrier+  barrier    sComment "restore correct values for first block" $-    sWhen is_first_block write_final_result+    sWhen is_first_block $forM_ (zip3 x_params y_params arrs) $ \(x, y, arr) ->+      if primType (paramType y)+      then copyDWIM arr [DimFix ltid] (Var $ paramName y) []+      else copyDWIM (paramName x) [] (Var arr) [DimFix $ arrs_full_size + group_offset + ltid] -  sOp Imp.LocalBarrier+  barrier -inBlockScan :: Maybe (Imp.Exp -> Imp.Exp -> Imp.Exp)+inBlockScan :: KernelConstants+            -> Maybe (Imp.Exp -> Imp.Exp -> Imp.Exp)             -> Imp.Exp             -> Imp.Exp             -> Imp.Exp             -> Imp.Exp             -> [VName]+            -> InKernelGen ()             -> Lambda ExplicitMemory             -> InKernelGen ()-inBlockScan seg_flag lockstep_width block_size active ltid arrs scan_lam = everythingVolatile $ do+inBlockScan constants seg_flag arrs_full_size lockstep_width block_size active arrs barrier scan_lam = everythingVolatile $ do   skip_threads <- dPrim "skip_threads" int32   let in_block_thread_active =         Imp.var skip_threads int32 .<=. in_block_id       actual_params = lambdaParams scan_lam       (x_params, y_params) =         splitAt (length actual_params `div` 2) actual_params-      read_operands =-        zipWithM_ (readParamFromLocalMemory $ ltid - Imp.var skip_threads int32)-        x_params arrs+      y_to_x =+        forM_ (zip x_params y_params) $ \(x,y) ->+        when (primType (paramType x)) $+        copyDWIM (paramName x) [] (Var (paramName y)) []    -- Set initial y values-  sWhen active $-    zipWithM_ (readParamFromLocalMemory ltid) y_params arrs+  sWhen active $ do+    zipWithM_ readInitial y_params arrs+    -- Since the final result is expected to be in x_params, we may+    -- need to copy it there for the first thread in the block.+    sWhen (in_block_id .==. 0) y_to_x -  let op_to_y+  when array_scan barrier++  let op_to_x         | Nothing <- seg_flag =-            compileBody' y_params $ lambdaBody scan_lam-        | Just flag_true <- seg_flag =-            sUnless (flag_true (ltid-Imp.var skip_threads int32) ltid) $-              compileBody' y_params $ lambdaBody scan_lam-      write_operation_result =-        zipWithM_ (writeParamToLocalMemory ltid) arrs y_params-      maybeLocalBarrier = sWhen (lockstep_width .<=. Imp.var skip_threads int32) $-                          sOp Imp.LocalBarrier+            compileBody' x_params $ lambdaBody scan_lam+        | Just flag_true <- seg_flag = do+            inactive <- dPrimVE "inactive" $+                        flag_true (ltid-Imp.var skip_threads int32) ltid+            sWhen inactive y_to_x+            when array_scan barrier+            sUnless inactive $ compileBody' x_params $ lambdaBody scan_lam +      maybeBarrier = sWhen (lockstep_width .<=. Imp.var skip_threads int32)+                     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+        sComment "read operands" $+          zipWithM_ (readParam (Imp.vi32 skip_threads)) x_params arrs+        sComment "perform operation" op_to_x -      maybeLocalBarrier+      maybeBarrier        sWhen (in_block_thread_active .&&. active) $-        sComment "write result" write_operation_result+        sComment "write result" $+        sequence_ $ zipWith3 writeResult x_params y_params arrs -      maybeLocalBarrier+      maybeBarrier        skip_threads <-- Imp.var skip_threads int32 * 2    where block_id = ltid `quot` block_size         in_block_id = ltid - block_id * block_size+        ltid = kernelLocalThreadId constants+        gtid = kernelGlobalThreadId constants+        array_scan = not $ all primType $ lambdaReturnType scan_lam -getSize :: String -> Imp.SizeClass -> CallKernelGen VName-getSize desc sclass = do-  size <- dPrim desc int32-  fname <- asks envFunction-  let size_key = keyWithEntryPoint fname $ nameFromString $ pretty size-  sOp $ Imp.GetSize size size_key sclass-  return size+        readInitial p arr+          | primType $ paramType p =+              copyDWIM (paramName p) [] (Var arr) [DimFix ltid]+          | otherwise =+              copyDWIM (paramName p) [] (Var arr) [DimFix gtid] +        readParam behind p arr+          | primType $ paramType p =+              copyDWIM (paramName p) [] (Var arr) [DimFix $ ltid - behind]+          | otherwise =+              copyDWIM (paramName p) [] (Var arr) [DimFix $ gtid - behind + arrs_full_size]++        writeResult x y arr+          | primType $ paramType x = do+              copyDWIM arr [DimFix ltid] (Var $ paramName x) []+              copyDWIM (paramName y) [] (Var $ paramName x) []+          | otherwise =+              copyDWIM (paramName y) [] (Var $ paramName x) []+ computeMapKernelGroups :: Imp.Exp -> CallKernelGen (Imp.Exp, Imp.Exp) computeMapKernelGroups kernel_size = do   group_size <- dPrim "group_size" int32@@ -1017,24 +1067,22 @@     m =<< dPrimV "virt_group_id" (Imp.vi32 phys_group_id + i * kernelNumGroups constants)     -- Make sure the virtual group is actually done before we let     -- another virtual group have its way with it.-    sOp Imp.GlobalBarrier-    sOp Imp.LocalBarrier+    sOp $ Imp.Barrier Imp.FenceGlobal -sKernelThread, sKernelGroup :: String-                            -> Count NumGroups Imp.Exp -> Count GroupSize Imp.Exp-                            -> VName-                            -> (KernelConstants -> InKernelGen ())-                            -> CallKernelGen ()-(sKernelThread, sKernelGroup) = (sKernel' threadOperations kernelGlobalThreadId,-                                 sKernel' groupOperations kernelGroupId)-  where sKernel' ops flatf name num_groups group_size v f = do-          (constants, set_constants) <- kernelInitialisationSimple num_groups group_size-          let name' = nameFromString $ name ++ "_" ++ show (baseTag v)-          sKernel (ops constants) constants name' $ do-            set_constants-            dPrimV_ v $ flatf constants-            f constants+sKernelThread :: String+              -> Count NumGroups Imp.Exp -> Count GroupSize Imp.Exp+              -> VName+              -> (KernelConstants -> InKernelGen ())+              -> CallKernelGen ()+sKernelThread = sKernel threadOperations kernelGlobalThreadId +sKernelGroup :: String+             -> Count NumGroups Imp.Exp -> Count GroupSize Imp.Exp+             -> VName+             -> (KernelConstants -> InKernelGen ())+             -> CallKernelGen ()+sKernelGroup = sKernel groupOperations kernelGroupId+ sKernelFailureTolerant :: Bool                        -> Operations ExplicitMemory Imp.KernelOp                        -> KernelConstants@@ -1053,20 +1101,20 @@     , Imp.kernelFailureTolerant = tol     } -sKernel :: Operations ExplicitMemory Imp.KernelOp-        -> KernelConstants -> Name -> ImpM ExplicitMemory Imp.KernelOp a -> CallKernelGen ()-sKernel = sKernelFailureTolerant False---- | A kernel with the given number of threads, running per-thread code.-sKernelSimple :: String -> Imp.Exp-              -> (KernelConstants -> InKernelGen ())-              -> CallKernelGen ()-sKernelSimple name kernel_size f = do-  (constants, init_constants) <- simpleKernelConstants kernel_size name-  let name' = nameFromString $ name ++ "_" ++-              show (baseTag $ kernelGlobalThreadIdVar constants)-  sKernel (threadOperations constants) constants name' $ do-    init_constants+sKernel :: (KernelConstants -> Operations ExplicitMemory Imp.KernelOp)+        -> (KernelConstants -> Imp.Exp)+        -> String+        -> Count NumGroups Imp.Exp+        -> Count GroupSize Imp.Exp+        -> VName+        -> (KernelConstants -> ImpM ExplicitMemory Imp.KernelOp a)+        -> ImpM ExplicitMemory Imp.HostOp ()+sKernel ops flatf name num_groups group_size v f = do+  (constants, set_constants) <- kernelInitialisationSimple num_groups group_size+  let name' = nameFromString $ name ++ "_" ++ show (baseTag v)+  sKernelFailureTolerant False (ops constants) constants name' $ do+    set_constants+    dPrimV_ v $ flatf constants     f constants  copyInGroup :: CopyCompiler ExplicitMemory Imp.KernelOp@@ -1089,8 +1137,7 @@   , opsExpCompiler = compileThreadExp   , opsStmsCompiler = \_ -> defCompileStms mempty   , opsAllocCompilers =-      M.fromList [ (Space "local", allocLocal)-                 , (Space "private", allocPrivate) ]+      M.fromList [ (Space "local", allocLocal) ]   } groupOperations constants =   (defaultOperations $ compileGroupOp constants)@@ -1098,8 +1145,7 @@   , opsExpCompiler = compileGroupExp constants   , opsStmsCompiler = \_ -> defCompileStms mempty   , opsAllocCompilers =-      M.fromList [ (Space "local", allocLocal)-                 , (Space "private", allocPrivate) ]+      M.fromList [ (Space "local", allocLocal) ]   }  -- | Perform a Replicate with a kernel.

@@ -44,7 +44,7 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Maybe-import Data.List+import Data.List (foldl', genericLength, zip4, zip6)  import Prelude hiding (quot, rem) @@ -602,7 +602,7 @@         (sLoopNest (histShape op) $ \is ->             copyDWIMFix dest_local (local_is++is) ne []) -    sOp Imp.LocalBarrier+    sOp $ Imp.Barrier Imp.FenceLocal      kernelLoop pgtid_in_segment threads_per_segment segment_size' $ \ie -> do       dPrimV_ i_in_segment ie@@ -645,8 +645,7 @@                   copyDWIMFix (paramName p) [] v is                 do_op (bucket_is ++ is) -    sOp Imp.ErrorSync-    sOp Imp.GlobalBarrier+    sOp $ Imp.ErrorSync Imp.FenceGlobal      sComment "Compact the multiple local memory subhistograms to result in global memory" $       onSlugs $ \slug dests hist_H_chk histo_dims histo_size -> do

@@ -50,7 +50,7 @@  import Control.Monad.Except import Data.Maybe-import Data.List+import Data.List (genericLength, zip4, zip7)  import Prelude hiding (quot, rem) @@ -273,15 +273,16 @@              isActive (init $ zip gtids dims) .&&.              ltid .<. segment_size * segments_per_group) in_bounds out_of_bounds -      sOp Imp.ErrorSync -- Also implicitly barrier.+      sOp $ Imp.ErrorSync Imp.FenceLocal -- Also implicitly barrier.        let crossesSegment from to = (to-from) .>. (to `rem` segment_size)       sWhen (segment_size .>. 0) $         sComment "perform segmented scan to imitate reduction" $         forM_ (zip reds reds_arrs) $ \(SegRedOp _ red_op _ _, red_arrs) ->-        groupScan constants (Just crossesSegment) (segment_size*segments_per_group) red_op red_arrs+        groupScan constants (Just crossesSegment) (Imp.vi32 num_threads)+        (segment_size*segments_per_group) red_op red_arrs -      sOp Imp.LocalBarrier+      sOp $ Imp.Barrier Imp.FenceLocal        sComment "save final values of segments" $         sWhen (group_id' * segments_per_group + ltid .<. num_segments .&&.@@ -295,7 +296,7 @@        -- Finally another barrier, because we will be writing to the       -- local memory array first thing in the next iteration.-      sOp Imp.LocalBarrier+      sOp $ Imp.Barrier Imp.FenceLocal  largeSegmentsReduction :: Pattern ExplicitMemory                        -> Count NumGroups SubExp -> Count GroupSize SubExp@@ -500,11 +501,11 @@               when (primType $ paramType p) $               copyDWIMFix arr [local_tid] (Var $ paramName p) [] -          sOp Imp.ErrorSync -- Also implicitly barrier.+          sOp $ Imp.ErrorSync Imp.FenceLocal -- Also implicitly barrier.            groupReduce constants (kernelGroupSize constants) slug_op_renamed (slugArrs slug) -          sOp Imp.LocalBarrier+          sOp $ Imp.Barrier Imp.FenceLocal            sComment "first thread saves the result in accumulator" $             sWhen (local_tid .==. 0) $@@ -616,7 +617,7 @@     sWhen (local_tid .==. 0) $ do     forM_ (take (length nes) $ zip group_res_arrs (slugAccs slug)) $ \(v, (acc, acc_is)) ->       copyDWIMFix v [0, group_id] (Var acc) acc_is-    sOp Imp.MemFenceGlobal+    sOp $ Imp.MemFence Imp.FenceGlobal     -- Increment the counter, thus stating that our result is     -- available.     sOp $ Imp.Atomic DefaultSpace $ Imp.AtomicAdd old_counter counter_mem counter_offset 1@@ -624,8 +625,7 @@     -- so, it is our responsibility to produce the final result.     sWrite sync_arr [0] $ Imp.var old_counter int32 .==. groups_per_segment - 1 -  sOp Imp.LocalBarrier-  sOp Imp.GlobalBarrier+  sOp $ Imp.Barrier Imp.FenceGlobal    is_last_group <- dPrim "is_last_group" Bool   copyDWIMFix is_last_group [] (Var sync_arr) [0]@@ -653,7 +653,7 @@           when (primType $ paramType p) $             copyDWIMFix arr [local_tid] (Var $ paramName p) [] -      sOp Imp.LocalBarrier+      sOp $ Imp.Barrier Imp.FenceLocal        sComment "reduce the per-group results" $ do         groupReduce constants group_size red_op_renamed red_arrs

@@ -6,7 +6,7 @@  import Control.Monad.Except import Data.Maybe-import Data.List+import Data.List ()  import Prelude hiding (quot, rem) @@ -36,12 +36,18 @@  type CrossesSegment = Maybe (Imp.Exp -> Imp.Exp -> Imp.Exp) +localArrayIndex :: KernelConstants -> Type -> Imp.Exp+localArrayIndex constants t =+  if primType t+  then kernelLocalThreadId constants+  else kernelGlobalThreadId constants+ -- | Produce partially scanned intervals; one per workgroup. scanStage1 :: Pattern ExplicitMemory            -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace            -> Lambda ExplicitMemory -> [SubExp]            -> KernelBody ExplicitMemory-           -> CallKernelGen (Imp.Exp, CrossesSegment)+           -> CallKernelGen (VName, Imp.Exp, CrossesSegment) scanStage1 (Pattern _ pes) num_groups group_size space scan_op nes kbody = do   num_groups' <- traverse toExp num_groups   group_size' <- traverse toExp group_size@@ -49,6 +55,7 @@                  unCount num_groups' * unCount group_size'    let (gtids, dims) = unzip $ unSegSpace space+      rets = lambdaReturnType scan_op   dims' <- mapM toExp dims   let num_elements = product dims'       elems_per_thread = num_elements `quotRoundingUp` Imp.vi32 num_threads@@ -65,8 +72,7 @@           _ -> Nothing    sKernelThread "scan_stage1" num_groups' group_size' (segFlat space) $ \constants -> do-    local_arrs <--      makeLocalArrays group_size (Var num_threads) nes scan_op+    local_arrs <- makeLocalArrays group_size (Var num_threads) nes scan_op      -- The variables from scan_op will be used for the carry and such     -- in the big chunking loop.@@ -105,8 +111,8 @@        sComment "combine with carry and write to local memory" $         compileStms mempty (bodyStms $ lambdaBody scan_op) $-        forM_ (zip local_arrs $ bodyResult $ lambdaBody scan_op) $ \(arr, se) ->-          copyDWIMFix arr [kernelLocalThreadId constants] se []+        forM_ (zip3 rets local_arrs (bodyResult $ lambdaBody scan_op)) $ \(t, arr, se) ->+        copyDWIMFix arr [localArrayIndex constants t] se []        let crossesSegment' = do             f <- crossesSegment@@ -115,48 +121,64 @@                   to' = to + Imp.var chunk_offset int32               in f from' to' -      sOp Imp.ErrorSync -- Also implicitly barrier.+      sOp $ Imp.ErrorSync fence        groupScan constants crossesSegment'+        (Imp.vi32 num_threads)         (kernelGroupSize constants) scan_op_renamed local_arrs        sComment "threads in bounds write partial scan result" $-        sWhen in_bounds $ forM_ (zip pes local_arrs) $ \(pe, arr) ->+        sWhen in_bounds $ forM_ (zip3 rets pes local_arrs) $ \(t, pe, arr) ->         copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)-        (Var arr) [kernelLocalThreadId constants]+        (Var arr) [localArrayIndex constants t] -      sOp Imp.LocalBarrier+      barrier        let load_carry =             forM_ (zip local_arrs scan_x_params) $ \(arr, p) ->-            copyDWIMFix (paramName p) [] (Var arr) [kernelGroupSize constants - 1]+            copyDWIMFix (paramName p) [] (Var arr)+            [if primType $ paramType p+             then kernelGroupSize constants - 1+             else (kernelGroupId constants+1) * kernelGroupSize constants - 1]           load_neutral =             forM_ (zip nes scan_x_params) $ \(ne, p) ->             copyDWIMFix (paramName p) [] ne [] -      sComment "first thread reads last element as carry-in for next iteration" $-        sWhen (kernelLocalThreadId constants .==. 0) $-        case crossesSegment of Nothing -> load_carry-                               Just f -> sIf (f (Imp.var chunk_offset int32 +-                                                 kernelGroupSize constants-1)-                                                (Imp.var chunk_offset int32 +-                                                 kernelGroupSize constants))-                                         load_neutral load_carry+      sComment "first thread reads last element as carry-in for next iteration" $ do+        crosses_segment <- dPrimVE "crosses_segment" $+          case crossesSegment of+            Nothing -> false+            Just f -> f (Imp.var chunk_offset int32 ++                         kernelGroupSize constants-1)+                        (Imp.var chunk_offset int32 ++                         kernelGroupSize constants)+        should_load_carry <- dPrimVE "should_load_carry" $+          kernelLocalThreadId constants .==. 0 .&&. UnOpExp Not crosses_segment+        sWhen should_load_carry load_carry+        when array_scan barrier+        sUnless should_load_carry load_neutral -      sOp Imp.LocalBarrier+      barrier -  return (elems_per_group, crossesSegment)+  return (num_threads, elems_per_group, crossesSegment) +  where array_scan = not $ all primType $ lambdaReturnType scan_op+        fence | array_scan = Imp.FenceGlobal+              | otherwise = Imp.FenceLocal+        barrier = sOp $ Imp.Barrier fence++ scanStage2 :: Pattern ExplicitMemory-           -> Imp.Exp -> Count NumGroups SubExp -> CrossesSegment -> SegSpace+           -> VName -> Imp.Exp -> Count NumGroups SubExp -> CrossesSegment -> SegSpace            -> Lambda ExplicitMemory -> [SubExp]            -> CallKernelGen ()-scanStage2 (Pattern _ pes) elems_per_group num_groups crossesSegment space scan_op nes = do+scanStage2 (Pattern _ pes) stage1_num_threads elems_per_group num_groups crossesSegment space scan_op nes = do   -- Our group size is the number of groups for the stage 1 kernel.   let group_size = Count $ unCount num_groups   group_size' <- traverse toExp group_size    let (gtids, dims) = unzip $ unSegSpace space+      rets = lambdaReturnType scan_op   dims' <- mapM toExp dims   let crossesSegment' = do         f <- crossesSegment@@ -164,8 +186,7 @@           f ((from + 1) * elems_per_group - 1) ((to + 1) * elems_per_group - 1)    sKernelThread  "scan_stage2" 1 group_size' (segFlat space) $ \constants -> do-    local_arrs <- makeLocalArrays group_size (unCount group_size)-                  nes scan_op+    local_arrs <- makeLocalArrays group_size (Var stage1_num_threads) nes scan_op      flat_idx <- dPrimV "flat_idx" $       (kernelLocalThreadId constants + 1) * elems_per_group - 1@@ -174,37 +195,46 @@      let in_bounds =           foldl1 (.&&.) $ zipWith (.<.) (map (`Imp.var` int32) gtids) dims'-        when_in_bounds = forM_ (zip local_arrs pes) $ \(arr, pe) ->-          copyDWIMFix arr [kernelLocalThreadId constants]+        when_in_bounds = forM_ (zip3 rets local_arrs pes) $ \(t, arr, pe) ->+          copyDWIMFix arr [localArrayIndex constants t]           (Var $ patElemName pe) $ map (`Imp.var` int32) gtids-        when_out_of_bounds = forM_ (zip local_arrs nes) $ \(arr, ne) ->-          copyDWIMFix arr [kernelLocalThreadId constants] ne []+        when_out_of_bounds = forM_ (zip3 rets local_arrs nes) $ \(t, arr, ne) ->+          copyDWIMFix arr [localArrayIndex constants t] ne []      sComment "threads in bound read carries; others get neutral element" $       sIf in_bounds when_in_bounds when_out_of_bounds      groupScan constants crossesSegment'-      (kernelGroupSize constants) scan_op local_arrs+      (Imp.vi32 stage1_num_threads) (kernelGroupSize constants) scan_op local_arrs      sComment "threads in bounds write scanned carries" $-      sWhen in_bounds $ forM_ (zip pes local_arrs) $ \(pe, arr) ->+      sWhen in_bounds $ forM_ (zip3 rets pes local_arrs) $ \(t, pe, arr) ->       copyDWIMFix (patElemName pe) (map (`Imp.var` int32) gtids)-      (Var arr) [kernelLocalThreadId constants]+      (Var arr) [localArrayIndex constants t]  scanStage3 :: Pattern ExplicitMemory+           -> Count NumGroups SubExp -> Count GroupSize SubExp            -> Imp.Exp -> CrossesSegment -> SegSpace            -> Lambda ExplicitMemory -> [SubExp]            -> CallKernelGen ()-scanStage3 (Pattern _ pes) elems_per_group crossesSegment space scan_op nes = do+scanStage3 (Pattern _ pes) num_groups group_size elems_per_group crossesSegment space scan_op nes = do+  num_groups' <- traverse toExp num_groups+  group_size' <- traverse toExp group_size   let (gtids, dims) = unzip $ unSegSpace space   dims' <- mapM toExp dims-  sKernelSimple "scan_stage3" (product dims') $ \constants -> do-    dPrimV_ (segFlat space) $ kernelGlobalThreadId constants+  required_groups <- dPrimVE "required_groups" $+                     product dims' `quotRoundingUp` unCount group_size'++  sKernelThread "scan_stage3" num_groups' group_size' (segFlat space) $ \constants ->+    virtualiseGroups constants SegVirt required_groups $ \virt_group_id -> do     -- Compute our logical index.-    zipWithM_ dPrimV_ gtids $ unflattenIndex dims' $ kernelGlobalThreadId constants+    flat_idx <- dPrimVE "flat_idx" $+                Imp.vi32 virt_group_id * unCount group_size' ++                kernelLocalThreadId constants+    zipWithM_ dPrimV_ gtids $ unflattenIndex dims' flat_idx+     -- Figure out which group this element was originally in.-    orig_group <- dPrimV "orig_group" $-                  kernelGlobalThreadId constants `quot` elems_per_group+    orig_group <- dPrimV "orig_group" $ flat_idx `quot` elems_per_group     -- Then the index of the carry-in of the preceding group.     carry_in_flat_idx <- dPrimV "carry_in_flat_idx" $                          Imp.var orig_group int32 * elems_per_group - 1@@ -215,15 +245,17 @@     -- group, and are not the last element in such a group (because     -- then the carry was updated in stage 2), and we are not crossing     -- a segment boundary.-    let crosses_segment = fromMaybe false $+    let in_bounds =+          foldl1 (.&&.) $ zipWith (.<.) (map (`Imp.var` int32) gtids) dims'+        crosses_segment = fromMaybe false $           crossesSegment <*>             pure (Imp.var carry_in_flat_idx int32) <*>-            pure (kernelGlobalThreadId constants)-        is_a_carry = kernelGlobalThreadId constants .==.+            pure flat_idx+        is_a_carry = flat_idx .==.                      (Imp.var orig_group int32 + 1) * elems_per_group - 1         no_carry_in = Imp.var orig_group int32 .==. 0 .||. is_a_carry .||. crosses_segment -    sWhen (kernelThreadActive constants) $ sUnless no_carry_in $ do+    sWhen in_bounds $ sUnless no_carry_in $ do       dScope Nothing $ scopeOfLParams $ lambdaParams scan_op       let (scan_x_params, scan_y_params) =             splitAt (length nes) $ lambdaParams scan_op@@ -245,12 +277,12 @@ compileSegScan pat lvl space scan_op nes kbody = do   emit $ Imp.DebugPrint "\n# SegScan" Nothing -  (elems_per_group, crossesSegment) <-+  (stage1_num_threads, elems_per_group, crossesSegment) <-     scanStage1 pat (segNumGroups lvl) (segGroupSize lvl) space scan_op nes kbody    emit $ Imp.DebugPrint "elems_per_group" $ Just elems_per_group    scan_op' <- renameLambda scan_op   scan_op'' <- renameLambda scan_op-  scanStage2 pat elems_per_group (segNumGroups lvl) crossesSegment space scan_op' nes-  scanStage3 pat elems_per_group crossesSegment space scan_op'' nes+  scanStage2 pat stage1_num_threads elems_per_group (segNumGroups lvl) crossesSegment space scan_op' nes+  scanStage3 pat (segNumGroups lvl) (segGroupSize lvl) elems_per_group crossesSegment space scan_op'' nes

@@ -466,9 +466,8 @@  hasCommunication :: ImpKernels.KernelCode -> Bool hasCommunication = any communicates-  where communicates ErrorSync = True-        communicates LocalBarrier = True-        communicates GlobalBarrier = True+  where communicates ErrorSync{} = True+        communicates Barrier{} = True         communicates _ = False  inKernelOperations :: ImpKernels.KernelCode -> GenericC.Operations KernelOp KernelState@@ -487,6 +486,9 @@   }   where has_communication = hasCommunication body +        fence FenceLocal = [C.cexp|CLK_LOCAL_MEM_FENCE|]+        fence FenceGlobal = [C.cexp|CLK_GLOBAL_MEM_FENCE|]+         kernelOps :: GenericC.OpCompiler KernelOp KernelState         kernelOps (GetGroupId v i) =           GenericC.stm [C.cstm|$id:v = get_group_id($int:i);|]@@ -500,34 +502,26 @@           GenericC.stm [C.cstm|$id:v = get_global_size($int:i);|]         kernelOps (GetLockstepWidth v) =           GenericC.stm [C.cstm|$id:v = LOCKSTEP_WIDTH;|]-        kernelOps LocalBarrier = do-          GenericC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|]-          GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True }-        kernelOps GlobalBarrier = do-          GenericC.stm [C.cstm|barrier(CLK_GLOBAL_MEM_FENCE);|]+        kernelOps (Barrier f) = do+          GenericC.stm [C.cstm|barrier($exp:(fence f));|]           GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True }-        kernelOps MemFenceLocal =+        kernelOps (MemFence FenceLocal) =           GenericC.stm [C.cstm|mem_fence_local();|]-        kernelOps MemFenceGlobal =+        kernelOps (MemFence FenceGlobal) =           GenericC.stm [C.cstm|mem_fence_global();|]-        kernelOps (PrivateAlloc name size) = do-          size' <- GenericC.compileExp $ unCount size-          name' <- newVName $ pretty name ++ "_backing"-          GenericC.item [C.citem|__private char $id:name'[$exp:size'];|]-          GenericC.stm [C.cstm|$id:name = $id:name';|]         kernelOps (LocalAlloc name size) = do           name' <- newVName $ pretty name ++ "_backing"           GenericC.modifyUserState $ \s ->             s { kernelLocalMemory = (name', size) : kernelLocalMemory s }           GenericC.stm [C.cstm|$id:name = (__local char*) $id:name';|]-        kernelOps ErrorSync = do+        kernelOps (ErrorSync f) = do           label <- nextErrorLabel           pending <- kernelSyncPending <$> GenericC.getUserState           when pending $ do             pendingError False-            GenericC.stm [C.cstm|$id:label: barrier(CLK_LOCAL_MEM_FENCE);|]+            GenericC.stm [C.cstm|$id:label: barrier($exp:(fence f));|]             GenericC.stm [C.cstm|if (local_failure) { return; }|]-          GenericC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|]+          GenericC.stm [C.cstm|barrier(CLK_LOCAL_MEM_FENCE);|] -- intentional           GenericC.modifyUserState $ \s -> s { kernelHasBarriers = True }           incErrorLabel         kernelOps (Atomic space aop) = atomicOps space aop

@@ -116,7 +116,7 @@                      t (Space "local") Nonvolatile $                      index idata (elements $ v32 idata_offset + v32 index_in)                      t (Space "global") Nonvolatile]-      , Op LocalBarrier+      , Op $ Barrier FenceLocal       , 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) $@@ -199,7 +199,7 @@             t (Space "local") Nonvolatile $             index idata (elements $ v32 idata_offset + v32 index_in)             t (Space "global") Nonvolatile-          , Op LocalBarrier+          , Op $ Barrier FenceLocal           , SetScalar x_index x_out_index           , SetScalar y_index y_out_index           , dec index_out $ v32 y_index * height + v32 x_index

@@ -23,7 +23,7 @@ import Control.Monad.Except import qualified Data.Map.Strict as M import Data.Maybe-import Data.List+import Data.List (intercalate) import qualified System.FilePath.Posix as Posix import System.IO.Error import qualified Data.Text as T

@@ -62,7 +62,7 @@  import qualified Data.Map.Strict as M import Data.Loc (SrcLoc)-import Data.List+import Data.List (sortOn) import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer

@@ -2,7 +2,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fmax-pmcheck-iterations=25000000#-} -- | -- -- This module implements a transformation from source to core@@ -16,7 +15,7 @@ import Data.Bitraversable import qualified Data.Map.Strict as M import qualified Data.Set as S-import Data.List+import Data.List (find, intercalate, intersperse, nub, transpose) import qualified Data.List.NonEmpty as NE import Data.Loc import Data.Char (chr)@@ -166,8 +165,8 @@   PatternConstr c <$> (Info <$> allDimsFreshInType t) <*>   mapM allDimsFreshInPat pats <*> pure loc -generateEntryPoint :: E.StructType -> E.ValBind -> InternaliseM ()-generateEntryPoint ftype (E.ValBind _ ofname retdecl (Info (rettype, _)) _ params _ _ loc) = do+generateEntryPoint :: E.EntryPoint -> E.ValBind -> InternaliseM ()+generateEntryPoint (E.EntryPoint e_paramts e_rettype) (E.ValBind _ ofname _ (Info (rettype, _)) _ params _ _ loc) = do   -- We replace all shape annotations, so there should be no constant   -- parameters here.   params_fresh <- mapM allDimsFreshInPat params@@ -175,8 +174,7 @@                 mconcat $ map E.patternDimNames params_fresh   bindingParams tparams params_fresh $ \_ shapeparams params' -> do     (entry_rettype, _) <- internaliseEntryReturnType $ anySizes rettype-    let (e_paramts, e_rettype) = E.unfoldFunType ftype-        entry' = entryPoint (zip3 params e_paramts params') (retdecl, e_rettype, entry_rettype)+    let entry' = entryPoint (zip e_paramts params') (e_rettype, entry_rettype)         args = map (I.Var . I.paramName) $ concat params'      entry_body <- insertStmsM $ do@@ -197,40 +195,37 @@       (concat entry_rettype)       (shapeparams ++ concat params') entry_body -entryPoint :: [(E.Pattern, E.StructType, [I.FParam])]-           -> (Maybe (E.TypeExp VName), E.StructType, [[I.TypeBase ExtShape Uniqueness]])-           -> EntryPoint-entryPoint params (retdecl, eret, crets) =+entryPoint :: [(E.EntryType, [I.FParam])]+           -> (E.EntryType,+               [[I.TypeBase ExtShape Uniqueness]])+           -> I.EntryPoint+entryPoint params (eret, crets) =   (concatMap (entryPointType . preParam) params,-   case isTupleRecord eret of-     Just ts -> concatMap entryPointType $ zip3 retdecls ts crets-     _       -> entryPointType (retdecl, eret, concat crets))-  where preParam (p_pat, e_t, ps) = (paramOuterType p_pat,-                                     e_t,-                                     staticShapes $ map I.paramDeclType ps)-        paramOuterType (E.PatternAscription _ tdecl _) = Just $ declaredType tdecl-        paramOuterType (E.PatternParens p _) = paramOuterType p-        paramOuterType _ = Nothing--        retdecls = case retdecl of Just (TETuple tes _) -> map Just tes-                                   _                    -> repeat Nothing+   case (isTupleRecord $ entryType eret,+         entryAscribed eret) of+     (Just ts, Just (E.TETuple e_ts _)) ->+       concatMap entryPointType $+       zip (zipWith E.EntryType ts (map Just e_ts)) crets+     (Just ts, _) ->+       concatMap entryPointType $+       zip (map (`E.EntryType` Nothing) ts) crets+     _ ->+       entryPointType (eret, concat crets))+  where preParam (e_t, ps) = (e_t, staticShapes $ map I.paramDeclType ps) -        entryPointType :: (Maybe (E.TypeExp VName),-                           E.StructType,-                           [I.TypeBase ExtShape Uniqueness])-                       -> [EntryPointType]-        entryPointType (_, E.Scalar (E.Prim E.Unsigned{}), _) =-          [I.TypeUnsigned]-        entryPointType (_, E.Array _ _ (E.Prim E.Unsigned{}) _, _) =-          [I.TypeUnsigned]-        entryPointType (_, E.Scalar E.Prim{}, _) =-          [I.TypeDirect]-        entryPointType (_, E.Array _ _ E.Prim{} _, _) =-          [I.TypeDirect]-        entryPointType (te, t, ts) =-          [I.TypeOpaque desc $ length ts]-          where desc = maybe (pretty t') typeExpOpaqueName te-                t' = noSizes t `E.setUniqueness` Nonunique+        entryPointType (t, ts)+          | E.Scalar (E.Prim E.Unsigned{}) <- E.entryType t =+              [I.TypeUnsigned]+          | E.Array _ _ (E.Prim E.Unsigned{}) _ <- E.entryType t =+              [I.TypeUnsigned]+          | E.Scalar E.Prim{} <- E.entryType t =+              [I.TypeDirect]+          | E.Array _ _ E.Prim{} _ <- E.entryType t =+              [I.TypeDirect]+          | otherwise =+              [I.TypeOpaque desc $ length ts]+          where desc = maybe (pretty t') typeExpOpaqueName $ E.entryAscribed t+                t' = noSizes (E.entryType t) `E.setUniqueness` Nonunique          -- | We remove dimension arguments such that we hopefully end         -- up with a simpler type name for the entry point.  The@@ -541,7 +536,8 @@              let tag ses = [ (se, I.Observe) | se <- ses ]              args' <- reverse <$> mapM (internaliseArg arg_desc) (reverse args)              let args'' = concatMap tag args'-             letTupExp' desc $ I.Apply fname args'' [I.Prim rettype] (Safe, loc, [])+             letTupExp' desc $ I.Apply fname args'' [I.Prim rettype]+               (I.NotConstFun, Safe, loc, [])           | otherwise -> do              args' <- concat . reverse <$> mapM (internaliseArg arg_desc) (reverse args)@@ -1412,7 +1408,7 @@ internaliseDimConstant :: SrcLoc -> Name -> VName -> InternaliseM () internaliseDimConstant loc fname name =   letBind_ (basicPattern [] [I.Ident name $ I.Prim I.int32]) $-  I.Apply fname [] [I.Prim I.int32] (Safe, loc, mempty)+  I.Apply fname [] [I.Prim I.int32] (I.ConstFun, Safe, loc, mempty)  -- | Some operators and functions are overloaded or otherwise special -- - we detect and treat them here.@@ -1420,29 +1416,30 @@                      -> Maybe (String -> InternaliseM [SubExp]) isOverloadedFunction qname args loc = do   guard $ baseTag (qualLeaf qname) <= maxIntrinsicTag-  handle args $ baseString $ qualLeaf qname+  let handlers = [handleSign,+                  handleIntrinsicOps,+                  handleOps,+                  handleSOACs,+                  handleRest]+  msum [h args $ baseString $ qualLeaf qname | h <- handlers]   where-    handle [x] "sign_i8"  = Just $ toSigned I.Int8 x-    handle [x] "sign_i16" = Just $ toSigned I.Int16 x-    handle [x] "sign_i32" = Just $ toSigned I.Int32 x-    handle [x] "sign_i64" = Just $ toSigned I.Int64 x--    handle [x] "unsign_i8"  = Just $ toUnsigned I.Int8 x-    handle [x] "unsign_i16" = Just $ toUnsigned I.Int16 x-    handle [x] "unsign_i32" = Just $ toUnsigned I.Int32 x-    handle [x] "unsign_i64" = Just $ toUnsigned I.Int64 x+    handleSign [x] "sign_i8"  = Just $ toSigned I.Int8 x+    handleSign [x] "sign_i16" = Just $ toSigned I.Int16 x+    handleSign [x] "sign_i32" = Just $ toSigned I.Int32 x+    handleSign [x] "sign_i64" = Just $ toSigned I.Int64 x -    handle [x] "!" = Just $ complementF x+    handleSign [x] "unsign_i8"  = Just $ toUnsigned I.Int8 x+    handleSign [x] "unsign_i16" = Just $ toUnsigned I.Int16 x+    handleSign [x] "unsign_i32" = Just $ toUnsigned I.Int32 x+    handleSign [x] "unsign_i64" = Just $ toUnsigned I.Int64 x -    handle [x] "opaque" = Just $ \desc ->-      mapM (letSubExp desc . BasicOp . Opaque) =<< internaliseExp "opaque_arg" x+    handleSign _ _ = Nothing -    handle [x] s+    handleIntrinsicOps [x] s       | Just unop <- find ((==s) . pretty) allUnOps = Just $ \desc -> do           x' <- internaliseExp1 "x" x           fmap pure $ letSubExp desc $ I.BasicOp $ I.UnOp unop x'--    handle [TupLit [x,y] _] s+    handleIntrinsicOps [TupLit [x,y] _] s       | Just bop <- find ((==s) . pretty) allBinOps = Just $ \desc -> do           x' <- internaliseExp1 "x" x           y' <- internaliseExp1 "y" y@@ -1451,22 +1448,23 @@           x' <- internaliseExp1 "x" x           y' <- internaliseExp1 "y" y           fmap pure $ letSubExp desc $ I.BasicOp $ I.CmpOp cmp x' y'-    handle [x] s+    handleIntrinsicOps [x] s       | Just conv <- find ((==s) . pretty) allConvOps = Just $ \desc -> do           x' <- internaliseExp1 "x" x           fmap pure $ letSubExp desc $ I.BasicOp $ I.ConvOp conv x'+    handleIntrinsicOps _ _ = Nothing      -- Short-circuiting operators are magical.-    handle [x,y] "&&" = Just $ \desc ->+    handleOps [x,y] "&&" = Just $ \desc ->       internaliseExp desc $       E.If x y (E.Literal (E.BoolValue False) noLoc) (Info $ E.Scalar $ E.Prim E.Bool, Info []) noLoc-    handle [x,y] "||" = Just $ \desc ->+    handleOps [x,y] "||" = Just $ \desc ->         internaliseExp desc $         E.If x (E.Literal (E.BoolValue True) noLoc) y (Info $ E.Scalar $ E.Prim E.Bool, Info []) noLoc      -- Handle equality and inequality specially, to treat the case of     -- arrays.-    handle [xe,ye] op+    handleOps [xe,ye] op       | Just cmp_f <- isEqlOp op = Just $ \desc -> do           xe' <- internaliseExp "x" xe           ye' <- internaliseExp "y" ye@@ -1514,7 +1512,7 @@                       I.If shapes_match compare_elems_body (resultBody [constant False]) $                       ifCommon [I.Prim I.Bool] -    handle [x,y] name+    handleOps [x,y] name       | Just bop <- find ((name==) . pretty) [minBound..maxBound::E.BinOp] =       Just $ \desc -> do         x' <- internaliseExp1 "x" x@@ -1524,9 +1522,72 @@             internaliseBinOp loc desc bop x' y' t1 t2           _ -> error "Futhark.Internalise.internaliseExp: non-primitive type in BinOp." -    handle [E.TupLit [a, si, v] _] "scatter" = Just $ scatterF a si v+    handleOps _ _ = Nothing -    handle [E.TupLit [e, E.ArrayLit vs _ _] _] "cmp_threshold" = do+    handleSOACs [TupLit [lam, arr] _] "map" = Just $ \desc -> do+      arr' <- internaliseExpToVars "map_arr" arr+      lam' <- internaliseMapLambda internaliseLambda lam $ map I.Var arr'+      w <- arraysSize 0 <$> mapM lookupType arr'+      letTupExp' desc $ I.Op $+        I.Screma w (I.mapSOAC lam') arr'++    handleSOACs [TupLit [lam, arr] _] "filter" = Just $ \_desc -> do+      arrs <- internaliseExpToVars "filter_input" arr+      lam' <- internalisePartitionLambda internaliseLambda 1 lam $ map I.Var arrs+      uncurry (++) <$> partitionWithSOACS 1 lam' arrs++    handleSOACs [TupLit [k, lam, arr] _] "partition" = do+      k' <- fromIntegral <$> isInt32 k+      Just $ \_desc -> do+        arrs <- internaliseExpToVars "partition_input" arr+        lam' <- internalisePartitionLambda internaliseLambda k' lam $ map I.Var arrs+        uncurry (++) <$> partitionWithSOACS k' lam' arrs+        where isInt32 (Literal (SignedValue (Int32Value k')) _) = Just k'+              isInt32 (IntLit k' (Info (E.Scalar (E.Prim (Signed Int32)))) _) = Just $ fromInteger k'+              isInt32 _ = Nothing++    handleSOACs [TupLit [lam, ne, arr] _] "reduce" = Just $ \desc ->+      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)+      where reduce w red_lam nes arrs =+              I.Screma w <$>+              I.reduceSOAC [Reduce Noncommutative red_lam nes] <*> pure arrs++    handleSOACs [TupLit [lam, ne, arr] _] "reduce_comm" = Just $ \desc ->+      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)+      where reduce w red_lam nes arrs =+              I.Screma w <$>+              I.reduceSOAC [Reduce Commutative red_lam nes] <*> pure arrs++    handleSOACs [TupLit [lam, ne, arr] _] "scan" = Just $ \desc ->+      internaliseScanOrReduce desc "scan" reduce (lam, ne, arr, loc)+      where reduce w scan_lam nes arrs =+              I.Screma w <$> I.scanSOAC scan_lam nes <*> pure arrs++    handleSOACs [TupLit [op, f, arr] _] "reduce_stream" = Just $ \desc ->+      internaliseStreamRed desc InOrder Noncommutative op f arr++    handleSOACs [TupLit [op, f, arr] _] "reduce_stream_per" = Just $ \desc ->+      internaliseStreamRed desc Disorder Commutative op f arr++    handleSOACs [TupLit [f, arr] _] "map_stream" = Just $ \desc ->+      internaliseStreamMap desc InOrder f arr++    handleSOACs [TupLit [f, arr] _] "map_stream_per" = Just $ \desc ->+      internaliseStreamMap desc Disorder f arr++    handleSOACs [TupLit [rf, dest, op, ne, buckets, img] _] "hist" = Just $ \desc ->+      internaliseHist desc rf dest op ne buckets img loc++    handleSOACs _ _ = Nothing++    handleRest [x] "!" = Just $ complementF x++    handleRest [x] "opaque" = Just $ \desc ->+      mapM (letSubExp desc . BasicOp . Opaque) =<< internaliseExp "opaque_arg" x++    handleRest [E.TupLit [a, si, v] _] "scatter" = Just $ scatterF a si v++    handleRest [E.TupLit [e, E.ArrayLit vs _ _] _] "cmp_threshold" = do       s <- mapM isCharLit vs       Just $ \desc -> do         x <- internaliseExp1 "threshold_x" e@@ -1534,7 +1595,7 @@       where isCharLit (Literal (SignedValue iv) _) = Just $ chr $ fromIntegral $ intToInt64 iv             isCharLit _                            = Nothing -    handle [E.TupLit [n, m, arr] _] "unflatten" = Just $ \desc -> do+    handleRest [E.TupLit [n, m, arr] _] "unflatten" = Just $ \desc -> do       arrs <- internaliseExpToVars "unflatten_arr" arr       n' <- internaliseExp1 "n" n       m' <- internaliseExp1 "m" m@@ -1551,7 +1612,7 @@         letSubExp desc $ I.BasicOp $           I.Reshape (reshapeOuter [DimNew n', DimNew m'] 1 $ I.arrayShape arr_t) arr' -    handle [arr] "flatten" = Just $ \desc -> do+    handleRest [arr] "flatten" = Just $ \desc -> do       arrs <- internaliseExpToVars "flatten_arr" arr       forM arrs $ \arr' -> do         arr_t <- lookupType arr'@@ -1561,7 +1622,7 @@         letSubExp desc $ I.BasicOp $           I.Reshape (reshapeOuter [DimNew k] 2 $ I.arrayShape arr_t) arr' -    handle [TupLit [x, y] _] "concat" = Just $ \desc -> do+    handleRest [TupLit [x, y] _] "concat" = Just $ \desc -> do       xs <- internaliseExpToVars "concat_x" x       ys <- internaliseExpToVars "concat_y" y       outer_size <- arraysSize 0 <$> mapM lookupType xs@@ -1574,7 +1635,7 @@             I.BasicOp $ I.Concat 0 xarr [yarr] ressize       letSubExps desc $ zipWith conc xs ys -    handle [TupLit [offset, e] _] "rotate" = Just $ \desc -> do+    handleRest [TupLit [offset, e] _] "rotate" = Just $ \desc -> do       offset' <- internaliseExp1 "rotation_offset" offset       internaliseOperation desc e $ \v -> do         r <- I.arrayRank <$> lookupType v@@ -1582,74 +1643,20 @@             offsets = offset' : replicate (r-1) zero         return $ I.Rotate offsets v -    handle [e] "transpose" = Just $ \desc ->+    handleRest [e] "transpose" = Just $ \desc ->       internaliseOperation desc e $ \v -> do         r <- I.arrayRank <$> lookupType v         return $ I.Rearrange ([1,0] ++ [2..r-1]) v -    handle [TupLit [x, y] _] "zip" = Just $ \desc ->+    handleRest [TupLit [x, y] _] "zip" = Just $ \desc ->       (++) <$> internaliseExp (desc ++ "_zip_x") x            <*> internaliseExp (desc ++ "_zip_y") y -    handle [TupLit [lam, arr] _] "map" = Just $ \desc -> do-      arr' <- internaliseExpToVars "map_arr" arr-      lam' <- internaliseMapLambda internaliseLambda lam $ map I.Var arr'-      w <- arraysSize 0 <$> mapM lookupType arr'-      letTupExp' desc $ I.Op $-        I.Screma w (I.mapSOAC lam') arr'--    handle [TupLit [lam, arr] _] "filter" = Just $ \_desc -> do-      arrs <- internaliseExpToVars "filter_input" arr-      lam' <- internalisePartitionLambda internaliseLambda 1 lam $ map I.Var arrs-      uncurry (++) <$> partitionWithSOACS 1 lam' arrs--    handle [TupLit [k, lam, arr] _] "partition" = do-      k' <- fromIntegral <$> isInt32 k-      Just $ \_desc -> do-        arrs <- internaliseExpToVars "partition_input" arr-        lam' <- internalisePartitionLambda internaliseLambda k' lam $ map I.Var arrs-        uncurry (++) <$> partitionWithSOACS k' lam' arrs-        where isInt32 (Literal (SignedValue (Int32Value k')) _) = Just k'-              isInt32 (IntLit k' (Info (E.Scalar (E.Prim (Signed Int32)))) _) = Just $ fromInteger k'-              isInt32 _ = Nothing--    handle [TupLit [lam, ne, arr] _] "reduce" = Just $ \desc ->-      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)-      where reduce w red_lam nes arrs =-              I.Screma w <$>-              I.reduceSOAC [Reduce Noncommutative red_lam nes] <*> pure arrs--    handle [TupLit [lam, ne, arr] _] "reduce_comm" = Just $ \desc ->-      internaliseScanOrReduce desc "reduce" reduce (lam, ne, arr, loc)-      where reduce w red_lam nes arrs =-              I.Screma w <$>-              I.reduceSOAC [Reduce Commutative red_lam nes] <*> pure arrs--    handle [TupLit [lam, ne, arr] _] "scan" = Just $ \desc ->-      internaliseScanOrReduce desc "scan" reduce (lam, ne, arr, loc)-      where reduce w scan_lam nes arrs =-              I.Screma w <$> I.scanSOAC scan_lam nes <*> pure arrs--    handle [TupLit [op, f, arr] _] "reduce_stream" = Just $ \desc ->-      internaliseStreamRed desc InOrder Noncommutative op f arr--    handle [TupLit [op, f, arr] _] "reduce_stream_per" = Just $ \desc ->-      internaliseStreamRed desc Disorder Commutative op f arr--    handle [TupLit [f, arr] _] "map_stream" = Just $ \desc ->-      internaliseStreamMap desc InOrder f arr--    handle [TupLit [f, arr] _] "map_stream_per" = Just $ \desc ->-      internaliseStreamMap desc Disorder f arr--    handle [TupLit [rf, dest, op, ne, buckets, img] _] "hist" = Just $ \desc ->-      internaliseHist desc rf dest op ne buckets img loc--    handle [x] "unzip" = Just $ flip internaliseExp x-    handle [x] "trace" = Just $ flip internaliseExp x-    handle [x] "break" = Just $ flip internaliseExp x+    handleRest [x] "unzip" = Just $ flip internaliseExp x+    handleRest [x] "trace" = Just $ flip internaliseExp x+    handleRest [x] "break" = Just $ flip internaliseExp x -    handle _ _ = Nothing+    handleRest _ _ = Nothing      toSigned int_to e desc = do       e' <- internaliseExp1 "trunc_arg" e@@ -1664,7 +1671,7 @@           letTupExp' desc $ I.BasicOp $ I.ConvOp (I.ZExt int_from int_to) e'         E.Scalar (E.Prim (E.FloatType float_from)) ->           letTupExp' desc $ I.BasicOp $ I.ConvOp (I.FPToSI float_from int_to) e'-        _ -> error "Futhark.Internalise.handle: non-numeric type in ToSigned"+        _ -> error "Futhark.Internalise: non-numeric type in ToSigned"      toUnsigned int_to e desc = do       e' <- internaliseExp1 "trunc_arg" e@@ -1759,7 +1766,8 @@                    " failed"         Just rettype -> do           ses <- fmap (map I.Var) $ letTupExp (baseString name) $-                 I.Apply fname (zip constargs const_ds) rettype (safety, loc, mempty)+                 I.Apply fname (zip constargs const_ds) rettype+                 (I.ConstFun, safety, loc, mempty)           bind_ext ses           return $ Just ses     _ -> return Nothing@@ -1769,7 +1777,7 @@   where arg (fname, name) = do           safety <- askSafety           se <- letSubExp (baseString name ++ "_arg") $-                I.Apply fname [] [I.Prim I.int32] (safety, loc, [])+                I.Apply fname [] [I.Prim I.int32] (I.ConstFun, safety, loc, [])           return (se, I.ObservePrim, I.Prim I.int32)  funcall :: String -> QualName VName -> [SubExp] -> SrcLoc@@ -1797,7 +1805,7 @@                "\nFunction has parameters\n " ++ pretty fun_params     Just ts -> do       safety <- askSafety-      ses <- letTupExp' desc $ I.Apply fname' (zip args' diets) ts (safety, loc, mempty)+      ses <- letTupExp' desc $ I.Apply fname' (zip args' diets) ts (I.NotConstFun, safety, loc, mempty)       return (ses, map I.fromDecl ts)  -- Bind existential names defined by an expression, based on the

@@ -9,7 +9,7 @@ import           Control.Monad.RWS hiding (Sum) import           Data.Bifunctor import           Data.Foldable-import           Data.List+import           Data.List (sortOn, nub, partition, tails) import qualified Data.List.NonEmpty as NE import           Data.Loc import           Data.Maybe@@ -763,7 +763,7 @@         comb (Scalar Arrow{}) t =           descend t         comb got et =-          descend $ fromStruct got `setUniqueness` uniqueness et `setAliases` aliases et+          descend $ fromStruct got `setAliases` aliases et          descend t@Array{}           | any (problematic . aliasVar) (aliases t) = t `setUniqueness` Nonunique

@@ -183,11 +183,20 @@                                        substituteInMod p_substs' arg_mod)) $ do           substs <- scopeSubsts <$> askScope           x <- evalModExp f_body-          return $ addSubsts abs abs_substs $ substituteInMod (b_substs <> substs) x+          return $+            addSubsts abs abs_substs $+            -- The next one is dubious, but is necessary to+            -- propagate substitutions from the argument (see+            -- modules/functor24.fut).+            addSubstsModMod (scopeSubsts $ modScope arg_mod) $+            substituteInMod (b_substs <> substs) x   where addSubsts abs substs (ModFun mabs (Scope msubsts mods) mp me) =           ModFun (abs<>mabs) (Scope (substs<>msubsts) mods) mp me         addSubsts _ substs (ModMod (Scope msubsts mods)) =           ModMod $ Scope (substs<>msubsts) mods+        addSubstsModMod substs (ModMod (Scope msubsts mods)) =+          ModMod $ Scope (substs<>msubsts) mods+        addSubstsModMod _ m = m evalModExp (ModLambda p ascript e loc) = do   scope <- askScope   abs <- asks envAbs

@@ -32,7 +32,7 @@ import           Control.Monad.Writer hiding (Sum) import           Data.Bitraversable import           Data.Bifunctor-import           Data.List+import           Data.List (partition) import           Data.Loc import qualified Data.Map.Strict as M import           Data.Maybe@@ -264,6 +264,9 @@       let funbind = PolyBinding rr (fname, tparams, params, retdecl, ret, [], body, loc)       pass $ do         (e', bs) <- listen $ extendEnv fname funbind $ transformExp e+        -- Do not remember this one for next time we monomorphise this+        -- function.+        modifyLifts $ filter ((/=fname) . fst . fst)         let (bs_local, bs_prop) = Seq.partition ((== fname) . fst) bs         return (unfoldLetFuns (map snd $ toList bs_local) e', const bs_prop) @@ -681,12 +684,14 @@ transformValBind valbind = do   valbind' <- toPolyBinding <$>               removeTypeVariables (isJust (valBindEntryPoint valbind)) valbind+   when (isJust $ valBindEntryPoint valbind) $ do     t <- removeTypeVariablesInType $ foldFunType          (map patternStructType (valBindParams valbind)) $          fst $ unInfo $ valBindRetType valbind     (name, _, valbind'') <- monomorphiseBinding True valbind' $ monoType t     tell $ Seq.singleton (name, valbind'' { valBindEntryPoint = valBindEntryPoint valbind})+   return mempty { envPolyBindings = M.singleton (valBindName valbind) valbind' }  transformTypeBind :: TypeBind -> MonoM Env

@@ -20,7 +20,7 @@  import Control.Monad.State import Control.Monad.Reader-import Data.List+import Data.List (delete, find, foldl') import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe

@@ -28,6 +28,7 @@ -- This affects SOACs in particular. module Futhark.Optimise.CSE        ( performCSE+       , performCSEOnFunDef        , CSEInOp        )        where@@ -55,6 +56,13 @@   Pass "CSE" "Combine common subexpressions." $   intraproceduralTransformation $   return . removeFunDefAliases . cseInFunDef cse_arrays . analyseFun++-- | Perform CSE on a single function.+performCSEOnFunDef :: (Attributes lore, CanBeAliased (Op lore),+                       CSEInOp (OpWithAliases (Op lore))) =>+                      Bool -> FunDef lore -> FunDef lore+performCSEOnFunDef cse_arrays =+  removeFunDefAliases . cseInFunDef cse_arrays . analyseFun  cseInFunDef :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) =>                Bool -> FunDef lore -> FunDef lore

@@ -30,7 +30,7 @@ import           Control.Monad.Reader import qualified Data.Map.Strict as M import           Data.Maybe-import           Data.List+import           Data.List (find)  import           Futhark.Construct import           Futhark.Representation.AST

@@ -17,7 +17,7 @@   )   where -import Data.List+import Data.List (mapAccumL) import qualified Data.Map.Strict as M import Data.Maybe 

@@ -19,7 +19,7 @@ import qualified Data.Set as S import qualified Data.Map.Strict as M import Data.Maybe-import Data.List+import Data.List (find, (\\), tails)  import Futhark.Representation.SOACS hiding (SOAC(..)) import qualified Futhark.Representation.SOACS as Futhark

@@ -2,13 +2,14 @@ -- | This module implements a compiler pass for inlining functions, -- then removing those that have become dead. module Futhark.Optimise.InliningDeadFun-  ( inlineAndRemoveDeadFunctions+  ( inlineFunctions+  , inlineConstants   , removeDeadFunctions   )   where  import Control.Monad.Identity-import Data.List+import Data.List (partition) import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M@@ -16,24 +17,31 @@  import Futhark.Representation.SOACS import Futhark.Representation.SOACS.Simplify (simpleSOACS, simplifyFun)+import Futhark.Optimise.CSE import Futhark.Transform.CopyPropagate (copyPropagateInFun) import Futhark.Transform.Rename import Futhark.Analysis.CallGraph import Futhark.Binder import Futhark.Pass -aggInlining :: MonadFreshNames m => CallGraph -> [FunDef SOACS] -> m [FunDef SOACS]-aggInlining cg = fmap (filter keep) .-                 recurse 0 .-                 filter isFunInCallGraph+aggInlineFunctions :: MonadFreshNames m =>+                      CallGraph -> [FunDef SOACS] -> m [FunDef SOACS]+aggInlineFunctions cg =+  fmap (filter keep) . recurse 0 . filter isFunInCallGraph   where isFunInCallGraph fundec =           isJust $ M.lookup (funDefName fundec) cg +        constfuns =+          S.fromList $ M.keys $ M.filter (==ConstFun) $ mconcat $ M.elems cg++        fdmap fds =+          M.fromList $ zip (map funDefName fds) fds+         noCallsTo :: (Name -> Bool) -> FunDef SOACS -> Bool         noCallsTo interesting fundec =           case M.lookup (funDefName fundec) cg of-            Just calls | not $ any interesting calls -> True-            _                                        -> False+            Just calls -> not $ any interesting (M.keys calls)+            _ -> False          -- The inverse rate at which we perform full simplification         -- after inlining.  For the other steps we just do copy@@ -55,97 +63,122 @@                 partition (noCallsTo                            (`elem` map funDefName to_be_inlined))                 maybe_inline_in-              inlined_but_entry_points =-                filter (isJust . funDefEntryPoint) to_be_inlined+              (not_actually_inlined, to_be_inlined') =+                partition keep to_be_inlined           if null to_be_inlined             then return funs-            else do let simplify-                          | i `rem` simplifyRate == 0 = simplifyFun-                          | otherwise = copyPropagateInFun simpleSOACS+            else do let simplify fd+                          | i `rem` simplifyRate == 0 ||+                            funDefName fd `S.member` constfuns =+                              copyPropagateInFun simpleSOACS =<<+                              performCSEOnFunDef True <$> simplifyFun fd+                          | otherwise =+                              copyPropagateInFun simpleSOACS fd                      let onFun = simplify <=< renameFun .-                                (`doInlineInCaller` to_be_inlined)-                    to_inline_in' <- recurse (i+1) . (not_to_inline_in++) =<<-                                     mapM onFun to_inline_in-                    return $ inlined_but_entry_points ++ to_inline_in'+                                doInlineInCaller (fdmap to_be_inlined') False+                    to_inline_in' <- mapM onFun to_inline_in+                    (not_actually_inlined<>) <$>+                      recurse (i+1) (not_to_inline_in <> to_inline_in') -        keep fundec = isJust (funDefEntryPoint fundec) || callsRecursive fundec+        keep fd =+          isJust (funDefEntryPoint fd)+          || callsRecursive fd+          || expensiveConstant fd -        callsRecursive fundec = maybe False (any recursive) $-                                M.lookup (funDefName fundec) cg+        expensiveConstant fd =+          funDefName fd `S.member` constfuns &&+          not (null (bodyStms (funDefBody fd))) +        callsRecursive fd = maybe False (any recursive . M.keys) $+                            M.lookup (funDefName fd) cg+         recursive fname = case M.lookup fname cg of-                            Just calls -> fname `elem` calls+                            Just calls -> fname `M.member` calls                             Nothing -> False --- | @doInlineInCaller caller inlcallees@ inlines in @calleer@ the functions--- in @inlcallees@. At this point the preconditions are that if @inlcallees@--- is not empty, and, more importantly, the functions in @inlcallees@ do--- not call any other functions. Further extensions that transform a--- tail-recursive function to a do or while loop, should do the transformation--- first and then do the inlining.-doInlineInCaller :: FunDef SOACS ->  [FunDef SOACS] -> FunDef SOACS-doInlineInCaller (FunDef entry name rtp args body) inlcallees =-  let body' = inlineInBody inlcallees body+-- | @doInlineInCaller constf fdmap caller@ inlines in @calleer@+-- the functions in @fdmap@ that are called as @constf@. At this+-- point the preconditions are that if @fdmap@ is not empty, and,+-- more importantly, the functions in @fdmap@ do not call any+-- other functions. Further extensions that transform a tail-recursive+-- function to a do or while loop, should do the transformation first+-- and then do the inlining.+doInlineInCaller :: M.Map Name (FunDef SOACS) -> Bool -> FunDef SOACS+                 -> FunDef SOACS+doInlineInCaller fdmap always_reshape (FunDef entry name rtp args body) =+  let body' = inlineInBody fdmap always_reshape body   in FunDef entry name rtp args body' -inlineInBody :: [FunDef SOACS] -> Body -> Body-inlineInBody inlcallees (Body attr stms res) =-  Body attr (stmsFromList $ inline (stmsToList stms)) res-  where inline (Let pat aux (Apply fname args _ (safety,loc,locs)) : rest)-          | fun:_ <- filter ((== fname) . funDefName) inlcallees =-              let param_names =-                    map paramName $ funDefParams fun-                  param_stms =-                    zipWith (reshapeIfNecessary param_names)-                    (map paramIdent $ funDefParams fun) (map fst args)-                  body_stms =-                    stmsToList $-                    addLocations safety (filter notNoLoc (loc:locs)) $-                    bodyStms $ funDefBody fun-                  res_stms =-                    certify (stmAuxCerts aux) <$>-                    zipWith (reshapeIfNecessary (patternNames pat))-                    (patternIdents pat) (bodyResult $ funDefBody fun)-              in param_stms <> body_stms <> res_stms <> inline rest-        inline (stm : rest) =-          inlineInStm inlcallees stm : inline rest-        inline [] = mempty+inlineFunction :: Bool+               -> Pattern+               -> StmAux attr+               -> [(SubExp, Diet)]+               -> (ConstFun, Safety, SrcLoc, [SrcLoc])+               -> FunDef SOACS+               -> [Stm]+inlineFunction always_reshape pat aux args (_,safety,loc,locs) fun =+  param_stms <> body_stms <> res_stms+  where param_names =+          map paramName $ funDefParams fun +        param_stms =+          zipWith (reshapeIfNecessary param_names)+          (map paramIdent $ funDefParams fun) (map fst args)++        body_stms =+          stmsToList $+          addLocations safety (filter notNoLoc (loc:locs)) $+          bodyStms $ funDefBody fun++        res_stms =+          certify (stmAuxCerts aux) <$>+          zipWith (reshapeIfNecessary (patternNames pat))+          (patternIdents pat) (bodyResult $ funDefBody fun)+         reshapeIfNecessary dim_names ident se           | t@Array{} <- identType ident,-            any (`elem` dim_names) $ subExpVars $ arrayDims t,+            always_reshape || any (`elem` dim_names) (subExpVars $ arrayDims t),             Var v <- se =               mkLet [] [ident] $ shapeCoerce (arrayDims t) v           | otherwise =               mkLet [] [ident] $ BasicOp $ SubExp se -notNoLoc :: SrcLoc -> Bool-notNoLoc = (/=NoLoc) . locOf+        notNoLoc = (/=NoLoc) . locOf -inliner :: Monad m => [FunDef SOACS] -> Mapper SOACS SOACS m-inliner funs = identityMapper { mapOnBody = const $ return . inlineInBody funs-                              , mapOnOp = return . inlineInSOAC funs-                              }+inlineInBody :: M.Map Name (FunDef SOACS) -> Bool -> Body -> Body+inlineInBody fdmap always_reshape = onBody+  where inline (Let pat aux (Apply fname args _ what) : rest)+          | Just fd <- M.lookup fname fdmap =+              inlineFunction always_reshape pat aux args what fd+              <> inline rest+        inline (stm : rest) =+          onStm stm : inline rest+        inline [] = mempty -inlineInSOAC :: [FunDef SOACS] -> SOAC SOACS -> SOAC SOACS-inlineInSOAC inlcallees = runIdentity . mapSOACM identitySOACMapper-                          { mapOnSOACLambda = return . inlineInLambda inlcallees-                          }+        onBody (Body attr stms res) =+          Body attr (stmsFromList $ inline (stmsToList stms)) res -inlineInStm :: [FunDef SOACS] -> Stm -> Stm-inlineInStm inlcallees (Let pat aux e) =-  Let pat aux $ mapExp (inliner inlcallees) e+        onStm (Let pat aux e) =+          Let pat aux $ mapExp inliner e -inlineInLambda :: [FunDef SOACS] -> Lambda -> Lambda-inlineInLambda inlcallees (Lambda params body ret) =-  Lambda params (inlineInBody inlcallees body) ret+        inliner =+          identityMapper { mapOnBody = const $ return . onBody+                         , mapOnOp = return . onSOAC+                         } +        onSOAC =+          runIdentity . mapSOACM identitySOACMapper+          { mapOnSOACLambda = return . onLambda }++        onLambda (Lambda params body ret) =+          Lambda params (onBody body) ret+ addLocations :: Safety -> [SrcLoc] -> Stms SOACS -> Stms SOACS addLocations caller_safety more_locs = fmap onStm   where onStm stm = stm { stmExp = onExp $ stmExp stm }-        onExp (Apply fname args t (safety, loc,locs)) =-          Apply fname args t (min caller_safety safety, loc,locs++more_locs)+        onExp (Apply fname args t (constf, safety, loc,locs)) =+          Apply fname args t (constf, min caller_safety safety, loc,locs++more_locs)         onExp (BasicOp (Assert cond desc (loc,locs))) =           case caller_safety of             Safe -> BasicOp $ Assert cond desc (loc,locs++more_locs)@@ -160,24 +193,71 @@         onLambda :: Lambda -> Lambda         onLambda lam = lam { lambdaBody = onBody $ lambdaBody lam } --- | A composition of 'inlineAggressively' and 'removeDeadFunctions',--- to avoid the cost of type-checking the intermediate stage.-inlineAndRemoveDeadFunctions :: Pass SOACS SOACS-inlineAndRemoveDeadFunctions =-  Pass { passName = "Inline and remove dead functions"+-- | Inline 'NotConstFun' functions and remove the resulting dead functions.+inlineFunctions :: Pass SOACS SOACS+inlineFunctions =+  Pass { passName = "Inline functions"        , passDescription = "Inline and remove resulting dead functions."        , passFunction = pass        }   where pass prog = do           let cg = buildCallGraph prog-          Prog <$> aggInlining cg (progFuns prog)+          Prog <$> aggInlineFunctions cg (progFuns prog) +aggInlineConstants :: [FunDef SOACS] -> [FunDef SOACS]+aggInlineConstants orig_fds =+  map inlineInEntry $ filter (isJust . funDefEntryPoint) orig_fds+  where fdmap = M.fromList $ zip (map funDefName orig_fds) orig_fds++        inlineInEntry fd =+          fd { funDefBody = constsInBody mempty $ funDefBody fd }++        constsInBody prev body =+          body { bodyStms = constsInStms prev (bodyStms body) }++        constsInStms prev stms =+          case stmsHead stms of+            Nothing -> mempty++            Just (Let pat aux (Apply fname args _ prop),+                  stms')+              | Just ses <- M.lookup fname prev ->+                  stmsFromList+                  (zipWith reshapeResult (patternIdents pat) ses)+                  <> constsInStms prev stms'++              | Just fd <- M.lookup fname fdmap ->+                  let stm_stms =+                        inlineFunction True pat aux args prop fd+                      prev' =+                        M.insert fname (map Var $ patternNames pat) prev+                  in constsInStms prev' $ stmsFromList stm_stms <> stms'++            Just (stm, stms') ->+              oneStm stm <> constsInStms prev stms'++        reshapeResult ident se+          | t@Array{} <- identType ident,+            Var v <- se =+              mkLet [] [ident] $ shapeCoerce (arrayDims t) v+          | otherwise =+              mkLet [] [ident] $ BasicOp $ SubExp se++-- | Inline 'ConstFun' functions and remove the resulting dead functions.+inlineConstants :: Pass SOACS SOACS+inlineConstants =+  Pass { passName = "Inline constants"+       , passDescription = "Inline and remove dead constants."+       , passFunction = pass+       }+  where pass prog = return $ Prog $ aggInlineConstants $ progFuns prog+ -- | @removeDeadFunctions prog@ removes the functions that are unreachable from -- the main function from the program. removeDeadFunctions :: Pass SOACS SOACS removeDeadFunctions =   Pass { passName = "Remove dead functions"-       , passDescription = "Remove the functions that are unreachable from the main function"+       , passDescription = "Remove the functions that are unreachable from entry points"        , passFunction = return . pass        }   where pass prog =

@@ -63,7 +63,7 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Either-import Data.List+import Data.List (find, foldl', nub, mapAccumL) import Data.Maybe  import Futhark.Representation.AST@@ -459,6 +459,8 @@ cheapExp (If _ tbranch fbranch _) = all cheapStm (bodyStms tbranch) &&                                     all cheapStm (bodyStms fbranch) cheapExp (Op op)                  = cheapOp op+cheapExp (Apply _ _ _ (constf, _, _, _)) =+  constf == ConstFun cheapExp _                        = True -- Used to be False, but                                          -- let's try it out. @@ -501,8 +503,11 @@       hoistbl_nms = filterBnds desirableToHoist getArrSz_fun $                     stmsToList $ stms1<>stms2 +      -- No matter what, we always want to hoist constants as much as+      -- possible.       isNotHoistableBnd _ _ _ (Let _ _ (BasicOp ArrayLit{})) = False       isNotHoistableBnd _ _ _ (Let _ _ (BasicOp SubExp{})) = False+      isNotHoistableBnd _ _ _ (Let _ _ (Apply _ _ _ (ConstFun, _, _, _))) = False       isNotHoistableBnd nms _ _ stm = not (hasPatName nms stm)        block = branch_blocker `orIf`

@@ -21,7 +21,7 @@  import Control.Monad import Data.Either-import Data.List+import Data.List (find, isSuffixOf, partition, sort) import Data.Maybe import qualified Data.Map.Strict as M @@ -343,7 +343,7 @@ removeUnnecessaryCopy (vtable,used) (Pattern [] [d]) _ (Copy v)   | not (v `UT.isConsumed` used),     (not (v `UT.used` used) && consumable) || not (patElemName d `UT.isConsumed` used) =-      Simplify $ letBind_ (Pattern [] [d]) $ BasicOp $ SubExp $ Var v+      Simplify $ letBindNames_ [patElemName d] $ BasicOp $ SubExp $ Var v   where -- We need to make sure we can even consume the original.         -- This is currently a hacky check, much too conservative,         -- because we don't have the information conveniently@@ -579,8 +579,8 @@       res <- m       case res of         SubExpResult cs' se ->-          certifying (cs<>cs') $ letBindNames_ (patternNames pat) $-          BasicOp $ SubExp se+          certifying (cs<>cs') $+          letBindNames_ (patternNames pat) $ BasicOp $ SubExp se         IndexResult extra_cs idd' inds' ->           certifying (cs<>extra_cs) $           letBindNames_ (patternNames pat) $ BasicOp $ Index idd' inds'@@ -832,7 +832,7 @@     ifsort /= IfFallback || isCt1 e1 = Simplify $ do   let ses = bodyResult branch   addStms $ bodyStms branch-  sequence_ [ letBind (Pattern [] [p]) $ BasicOp $ SubExp se+  sequence_ [ letBindNames_ [patElemName p] $ BasicOp $ SubExp se             | (p,se) <- zip (patternElements pat) ses]    where checkBranch@@ -869,9 +869,21 @@     all (safeExp . stmExp) $ bodyStms tbranch = Simplify $ do       let ses = bodyResult tbranch       addStms $ bodyStms tbranch-      sequence_ [ letBind (Pattern [] [p]) $ BasicOp $ SubExp se+      sequence_ [ letBindNames_ [patElemName p] $ BasicOp $ SubExp se                 | (p,se) <- zip (patternElements pat) ses] +ruleIf _ pat _ (cond, tb, fb, _)+  | Body _ _ [Constant (IntValue t)] <- tb,+    Body _ _ [Constant (IntValue f)] <- fb =+      if oneIshInt t && zeroIshInt f+      then Simplify $+           letBind_ pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond+      else if zeroIshInt t && oneIshInt f+      then Simplify $ do+        cond_neg <- letSubExp "cond_neg" $ BasicOp $ UnOp Not cond+        letBind_ pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond_neg+      else Skip+ ruleIf _ _ _ _ = Skip  -- | Move out results of a conditional expression whose computation is@@ -914,7 +926,7 @@         branchInvariant (pe, t, (tse, fse))           -- Do both branches return the same value?           | tse == fse = do-              letBind_ (Pattern [] [pe]) $ BasicOp $ SubExp tse+              letBindNames_ [patElemName pe] $ BasicOp $ SubExp tse               hoisted pe t            -- Do both branches return values that are free in the@@ -923,7 +935,7 @@           | invariant tse, invariant fse, patternSize pat > 1,             Prim _ <- patElemType pe, not $ sizeOfMem $ patElemName pe = do               bt <- expTypesFromPattern $ Pattern [] [pe]-              letBind_ (Pattern [] [pe]) =<<+              letBindNames_ [patElemName pe] =<<                 (If cond <$> resultBodyM [tse]                          <*> resultBodyM [fse]                          <*> pure (IfAttr bt ifsort))

@@ -10,7 +10,7 @@ import Control.Monad.Reader import qualified Data.Sequence as Seq import qualified Data.Map.Strict as M-import Data.List+import Data.List (foldl')  import Prelude hiding (quot) 

@@ -11,7 +11,7 @@ import Control.Monad.Writer import qualified Data.Map.Strict as M import Data.Maybe-import Data.List+import Data.List (foldl')  import Prelude hiding (quot) @@ -199,6 +199,11 @@                        stmsToList $ get_stms body   in (set_stms (stmsFromList stms) body, allocs) +expandable :: Space -> Bool+expandable (Space "local") = False+expandable ScalarSpace{} = False+expandable _ = True+ extractStmAllocations :: Names -> Stm ExplicitMemory                       -> Writer Extraction (Maybe (Stm ExplicitMemory)) extractStmAllocations bound_outside (Let (Pattern [] [patElem]) _ (Op (Alloc size space)))@@ -210,11 +215,6 @@         where visibleOutside (Var v) = v `nameIn` bound_outside               visibleOutside Constant{} = True -              expandable (Space "private") = False-              expandable (Space "local") = False-              expandable ScalarSpace{} = False-              expandable _ = True- extractStmAllocations bound_outside stm = do   e <- mapExpM expMapper $ stmExp stm   return $ Just $ stm { stmExp = e }@@ -403,7 +403,7 @@           return patElem { patElemAttr = new_attr }         inspectCtx patElem           | Mem space <- patElemType patElem,-            space `notElem` [Space "local", Space "private"] =+            expandable space =               throwError $ unwords ["Cannot deal with existential memory block",                                     pretty (patElemName patElem),                                     "when expanding inside kernels."]@@ -452,7 +452,9 @@                   , mapOnBranchType = offsetMemoryInBodyReturns                   , mapOnOp = onOp                   }-        onOp (Inner (SegOp op)) = Inner . SegOp <$> mapSegOpM segOpMapper op+        onOp (Inner (SegOp op)) =+          Inner . SegOp <$>+          localScope (scopeOfSegSpace (segSpace op)) (mapSegOpM segOpMapper op)           where segOpMapper =                   identitySegOpMapper { mapOnSegOpBody = offsetMemoryInKernelBody                                       , mapOnSegOpLambda = offsetMemoryInLambda

@@ -1064,12 +1064,11 @@ inThreadExpHints e =   mapM maybePrivate =<< expExtType e   where maybePrivate t-          | arrayRank t > 0,-            Just t' <- hasStaticShape t,-            all semiStatic $ arrayDims t' = do-              alloc_dims <- mapM dimAllocationSize $ arrayDims t'-              let ixfun = IxFun.iota $ map (primExpFromSubExp int32) alloc_dims-              return $ Hint ixfun $ Space "private"+          | Just (Array pt shape _) <- hasStaticShape t,+            all semiStatic $ shapeDims shape = do+              let ixfun = IxFun.iota $ map (primExpFromSubExp int32) $+                          shapeDims shape+              return $ Hint ixfun $ ScalarSpace (shapeDims shape) pt           | otherwise =               return NoHint 

@@ -31,7 +31,7 @@ import Control.Monad import Control.Monad.Writer import Control.Monad.Identity-import Data.List+import Data.List ()  import Prelude hiding (quot) 

@@ -44,7 +44,7 @@ import Control.Monad.Writer.Strict import Control.Monad.Trans.Maybe import Data.Maybe-import Data.List+import Data.List (find, partition, tails)  import Futhark.Representation.SOACS import qualified Futhark.Representation.SOACS.SOAC as SOAC

@@ -48,7 +48,7 @@ import qualified Data.Map.Strict as M import Data.Foldable import Data.Maybe-import Data.List+import Data.List (elemIndex, sortOn)  import Futhark.Representation.Kernels import Futhark.MonadFreshNames

@@ -16,7 +16,7 @@  import Control.Monad.RWS.Strict import Data.Maybe-import Data.List+import Data.List (find)  import Futhark.Pass.ExtractKernels.Distribution   (LoopNesting(..), KernelNest, kernelNestLoops)

@@ -11,7 +11,7 @@ import Control.Monad.State.Strict import qualified Data.Map.Strict as M import Data.Foldable-import Data.List+import Data.List (elemIndex, isPrefixOf, sort) import Data.Maybe  import Futhark.MonadFreshNames

@@ -34,7 +34,10 @@ standardPipeline :: Pipeline SOACS SOACS standardPipeline =   passes [ simplifySOACS-         , inlineAndRemoveDeadFunctions+         , inlineFunctions+         , simplifySOACS+         , performCSE True+         , inlineConstants          , simplifySOACS          , performCSE True          , simplifySOACS

@@ -18,6 +18,7 @@   )   where +import Control.Exception import Control.Monad.IO.Class import Data.Maybe import Data.IORef@@ -25,7 +26,7 @@ import qualified Data.Text as T import qualified Data.ByteString as BS import qualified Data.Text.Encoding as T-import Data.List+import Data.List (foldl', intersperse) import qualified System.FilePath.Posix as Posix import System.Exit import System.IO@@ -40,6 +41,11 @@ import Futhark.Util.Log import Futhark.Util (maybeHead) +-- | Catch 'HttpException's and turn them into an ordinary return+-- value.+httpMayThrow :: IO a -> IO (Either HttpException a)+httpMayThrow m = (Right <$> m) `catch` (pure . Left)+ -- | The manifest is stored as a monadic action, because we want to -- fetch them on-demand.  It would be a waste to fetch it information -- for every version of every package if we only actually need a small@@ -93,14 +99,17 @@   logMsg $ "Downloading " <> T.unpack url   r <- liftIO $ parseRequest $ T.unpack url -  r' <- liftIO $ httpLBS r   let bad = fail . (("When downloading " <> T.unpack url <> ": ")<>)-  case getResponseStatusCode r' of-    200 ->-      case Zip.toArchiveOrFail $ getResponseBody r' of-        Left e -> bad $ show e-        Right a -> return a-    x -> bad $ "got HTTP status " ++ show x+  http <- liftIO $ httpMayThrow $ httpLBS r+  case http of+    Left e -> bad $ "got network error:\n" ++ show e+    Right r' ->+      case getResponseStatusCode r' of+        200 ->+          case Zip.toArchiveOrFail $ getResponseBody r' of+            Left e -> bad $ show e+            Right a -> return a+        x -> bad $ "got HTTP status " ++ show x  -- | Information about a package.  The name of the package is stored -- separately.@@ -170,19 +179,22 @@   logMsg $ "Downloading package manifest from " <> url   r <- liftIO $ parseRequest $ T.unpack url -  r' <- liftIO $ httpBS r   let path = T.unpack $ owner <> "/" <> repo <> "@" <>              tag <> "/" <> T.pack futharkPkg       msg = (("When reading " <> path <> ": ")<>)-  case getResponseStatusCode r' of-    200 ->-      case T.decodeUtf8' $ getResponseBody r' of-        Left e -> fail $ msg $ show e-        Right s ->-          case parsePkgManifest path s of-            Left e -> fail $ msg $ errorBundlePretty e-            Right pm -> return pm-    x -> fail $ msg $ "got HTTP status " ++ show x+  http <- liftIO $ httpMayThrow $ httpBS r+  case http of+    Left e -> fail $ msg $ "got network error:\n" ++ show e+    Right r' ->+      case getResponseStatusCode r' of+        200 ->+          case T.decodeUtf8' $ getResponseBody r' of+            Left e -> fail $ msg $ show e+            Right s ->+              case parsePkgManifest path s of+                Left e -> fail $ msg $ errorBundlePretty e+                Right pm -> return pm+        x -> fail $ msg $ "got HTTP status " ++ show x  ghglLookupCommit :: (MonadIO m, MonadLogger m, MonadFail m) =>                     T.Text -> T.Text

@@ -38,7 +38,7 @@ import Control.Monad import Data.Either import Data.Foldable-import Data.List+import Data.List (sortOn) import Data.Maybe import Data.Traversable import Data.Void

@@ -36,7 +36,7 @@   )   where -import Data.List+import Data.List (find) import Data.Maybe (mapMaybe, isJust) import qualified Data.Map.Strict as M @@ -107,7 +107,8 @@         safeBasicOp _ = False  safeExp (DoLoop _ _ _ body) = safeBody body-safeExp (Apply fname _ _ _) = isBuiltInFunction fname+safeExp (Apply fname _ _ (constf, _, _, _)) =+  isBuiltInFunction fname || constf == ConstFun safeExp (If _ tbranch fbranch _) =   all (safeExp . stmExp) (bodyStms tbranch) &&   all (safeExp . stmExp) (bodyStms fbranch)

@@ -188,6 +188,10 @@ primOpRanges (ConvOp (SExt from to) x)   | from < to = [rangeOf x] +primOpRanges (ConvOp (BToI it) _) =+  [(Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (0::Int),+    Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (1::Int))]+ primOpRanges (Iota n x s Int32) =   [(Just $ ScalarBound x',     Just $ ScalarBound $ x' + (n' - 1) * s')]

@@ -8,7 +8,7 @@        , isMapTranspose        ) where -import Data.List+import Data.List (sortOn, tails)  import Futhark.Util 

@@ -220,10 +220,12 @@           maybeNest b | null $ bodyStms b = ppr b                       | otherwise         = nestedBlock "{" "}" $ ppr b   ppr (BasicOp op) = ppr op-  ppr (Apply fname args _ (safety, _, _)) =-    text (nameToString fname) <> safety' <> apply (map (align . pprArg) args)+  ppr (Apply fname args _ (constf, safety, _, _)) =+    text (nameToString fname) <> constf' <> safety' <> apply (map (align . pprArg) args)     where pprArg (arg, Consume) = text "*" <> ppr arg           pprArg (arg, _)       = ppr arg+          constf' = case constf of ConstFun -> text "<constant>"+                                   NotConstFun -> mempty           safety' = case safety of Unsafe -> text "<unsafe>"                                    Safe   -> mempty   ppr (Op op) = ppr op

@@ -43,6 +43,7 @@   , LoopForm (..)   , IfAttr (..)   , IfSort (..)+  , ConstFun (..)   , Safety (..)   , LambdaT(..)   , Lambda@@ -274,7 +275,7 @@   = BasicOp (BasicOp lore)     -- ^ A simple (non-recursive) operation. -  | Apply  Name [(SubExp, Diet)] [RetType lore] (Safety, SrcLoc, [SrcLoc])+  | Apply  Name [(SubExp, Diet)] [RetType lore] (ConstFun, Safety, SrcLoc, [SrcLoc])    | If     SubExp (BodyT lore) (BodyT lore) (IfAttr (BranchType lore)) @@ -287,6 +288,10 @@ deriving instance Annotations lore => Eq (ExpT lore) deriving instance Annotations lore => Show (ExpT lore) deriving instance Annotations lore => Ord (ExpT lore)++-- | Does this function call actually represent a reference to a+-- run-time constant?  This has implications for inlining.+data ConstFun = ConstFun | NotConstFun deriving (Eq, Ord, Show)  -- | Whether something is safe or unsafe (mostly function calls, and -- in the context of whether operations are dynamically checked).

@@ -94,7 +94,7 @@ import Control.Monad.Except import qualified Data.Map.Strict as M import Data.Foldable (traverse_, toList)-import Data.List+import Data.List (find) import qualified Data.Set as S  import Futhark.Analysis.Metrics

@@ -25,7 +25,7 @@        where  import Prelude hiding (mod, repeat)-import Data.List hiding (repeat)+import Data.List (sort, sortBy, zip4, zip5, zipWith5) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) import Data.Function (on)

@@ -10,7 +10,7 @@ where  import Control.Monad-import Data.List+import Data.List (find)  import qualified Futhark.Representation.AST.Syntax as AST import Futhark.Representation.AST.Syntax

@@ -53,7 +53,7 @@ import Control.Monad.Writer hiding (mapM_) import Control.Monad.Identity hiding (mapM_) import qualified Data.Map.Strict as M-import Data.List+import Data.List (intersperse)  import Futhark.Representation.AST import qualified Futhark.Analysis.Alias as Alias

@@ -15,7 +15,7 @@  import Control.Monad import Data.Foldable-import Data.List+import Data.List (isPrefixOf, groupBy, partition) import Data.Maybe import qualified Data.Map.Strict as M 

@@ -64,7 +64,9 @@         -- * Utility        , zeroIsh+       , zeroIshInt        , oneIsh+       , oneIshInt        , negativeIsh        , primBitSize        , primByteSize@@ -1041,10 +1043,7 @@  -- | Is the given value kind of one? oneIsh :: PrimValue -> Bool-oneIsh (IntValue (Int8Value k))      = k == 1-oneIsh (IntValue (Int16Value k))     = k == 1-oneIsh (IntValue (Int32Value k))     = k == 1-oneIsh (IntValue (Int64Value k))     = k == 1+oneIsh (IntValue k)                  = oneIshInt k oneIsh (FloatValue (Float32Value k)) = k == 1 oneIsh (FloatValue (Float64Value k)) = k == 1 oneIsh (BoolValue True)              = True@@ -1065,6 +1064,13 @@ zeroIshInt (Int32Value k) = k == 0 zeroIshInt (Int64Value k) = k == 0 +-- | Is the given integer value kind of one?+oneIshInt :: IntValue -> Bool+oneIshInt (Int8Value k)  = k == 1+oneIshInt (Int16Value k) = k == 1+oneIshInt (Int32Value k) = k == 1+oneIshInt (Int64Value k) = k == 1+ -- | Is the given integer value kind of negative? negativeIshInt :: IntValue -> Bool negativeIshInt (Int8Value k)  = k < 0@@ -1164,7 +1170,7 @@     where (from, to) = convOpType op  instance Pretty UnOp where-  ppr Not            = text "!"+  ppr Not            = text "not"   ppr (Abs t)        = taggedI "abs" t   ppr (FAbs t)       = taggedF "fabs" t   ppr (SSignum t)    = taggedI "ssignum" t

@@ -51,7 +51,7 @@ import Control.Monad.Identity import qualified Data.Map.Strict as M import Data.Maybe-import Data.List+import Data.List (intersperse)  import Futhark.Representation.AST import qualified Futhark.Analysis.Alias as Alias

@@ -23,7 +23,7 @@ import Control.Monad.Writer import Data.Foldable import Data.Either-import Data.List+import Data.List (partition, transpose, unzip6, zip6) import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Set      as S

@@ -49,7 +49,7 @@ import Data.Char import Data.Functor import Data.Maybe-import Data.List+import Data.List (foldl') import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T

@@ -52,7 +52,7 @@ import Control.Monad.Writer import Control.Monad.State import Control.Monad.RWS.Strict-import Data.List+import Data.List (find, intercalate, sort) import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Maybe

@@ -45,7 +45,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import Data.Char-import Data.List+import Data.List (genericDrop, genericSplitAt) import Data.Either import Data.Maybe import System.Environment@@ -245,9 +245,13 @@     go xs res = do       numThreads <- maybe getNumCapabilities pure concurrency       let (e,es) = splitAt numThreads xs-      mvars  <- mapM (fork f) e+      mvars  <- mapM (fork f') e       result <- mapM takeMVar mvars-      go es (result ++ res)+      case sequence result of+        Left err -> throw (err :: SomeException)+        Right result' -> go es (result' ++ res)++    f' x = (Right <$> f x) `catch` (pure . Left)  -- Z-encoding from https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/SymbolNames --

@@ -5,7 +5,7 @@      , Entry      ) where -import Data.List+import Data.List (intercalate, transpose) import System.Console.ANSI  data RowTemplate = RowTemplate [Int] Int deriving (Show)

@@ -111,7 +111,7 @@ import           Data.Foldable import qualified Data.Map.Strict       as M import qualified Data.Set              as S-import           Data.List+import           Data.List (sortOn, genericLength, isPrefixOf, nub) import           Data.Loc import           Data.Maybe import           Data.Ord

@@ -27,7 +27,8 @@ import Control.Monad.Reader import Data.Array import Data.Bifunctor (first)-import Data.List hiding (break)+import Data.List+  (transpose, genericLength, isPrefixOf, foldl', find, intercalate) import Data.Maybe import qualified Data.Map as M import qualified Data.List.NonEmpty as NE@@ -695,7 +696,11 @@  eval env (Parens e _ ) = eval env e -eval env (QualParens _ e _ ) = eval env e+eval env (QualParens (qv, _) e loc) = do+  m <- evalModuleVar env qv+  case m of+    ModuleFun{} -> error $ "Local open of module function at " ++ locStr loc+    Module m' -> eval (m'<>env) e  eval env (TupLit vs _) = toTuple <$> mapM (eval env) vs 

@@ -19,7 +19,7 @@ import           Data.Array import           Data.Functor import qualified Data.Map.Strict       as M-import           Data.List+import           Data.List (intersperse) import qualified Data.List.NonEmpty    as NE import           Data.Maybe import           Data.Monoid           hiding (Sum)

@@ -68,6 +68,8 @@   -- * Definitions   , DocComment(..)   , ValBindBase(..)+  , EntryPoint(..)+  , EntryType(..)   , Liftedness(..)   , TypeBindBase(..)   , TypeParamBase(..)@@ -99,7 +101,6 @@ import qualified Data.Set                         as S import           Data.Traversable import qualified Data.List.NonEmpty               as NE-import           Data.List import           Prelude  import           Futhark.Representation.Primitive (FloatType (..),@@ -118,6 +119,7 @@        Show (f PatternType),        Show (f (PatternType, [VName])),        Show (f (StructType, [VName])),+       Show (f EntryPoint),        Show (f Int),        Show (f StructType),        Show (f (StructType, Maybe VName)),@@ -821,24 +823,41 @@ instance Located DocComment where   locOf (DocComment _ loc) = locOf loc +-- | Part of the type of an entry point.  Has an actual type, and+-- maybe also an ascribed type expression.+data EntryType =+  EntryType { entryType :: StructType+            , entryAscribed :: Maybe (TypeExp VName)+            }+  deriving (Show)++-- | Information about the external interface exposed by an entry+-- point.  The important thing is that that we remember the original+-- source-language types, without desugaring them at all.  The+-- annoying thing is that we do not require type annotations on entry+-- points, so the types can be either ascribed or inferred.+data EntryPoint =+  EntryPoint { entryParams :: [EntryType]+             , entryReturn :: EntryType+             }+  deriving (Show)+ -- | Function Declarations-data ValBindBase f vn = ValBind { valBindEntryPoint :: Maybe (f StructType)-                                -- ^ True if this function is an entry-                                -- point.  If so, it also contains the-                                -- externally visible type.  Note that-                                -- this may not strictly be well-typed-                                -- after some desugaring operations,-                                -- as it may refer to abstract types-                                -- that are no longer in scope.-                                , valBindName       :: vn-                                , valBindRetDecl    :: Maybe (TypeExp vn)-                                , valBindRetType    :: f (StructType, [VName])-                                , valBindTypeParams :: [TypeParamBase vn]-                                , valBindParams     :: [PatternBase f vn]-                                , valBindBody       :: ExpBase f vn-                                , valBindDoc        :: Maybe DocComment-                                , valBindLocation   :: SrcLoc-                                }+data ValBindBase f vn = ValBind+  { valBindEntryPoint :: Maybe (f EntryPoint)+    -- ^ Just if this function is an entry point.  If so, it also+    -- contains the externally visible interface.  Note that this may not+    -- strictly be well-typed after some desugaring operations, as it+    -- may refer to abstract types that are no longer in scope.+  , valBindName       :: vn+  , valBindRetDecl    :: Maybe (TypeExp vn)+  , valBindRetType    :: f (StructType, [VName])+  , valBindTypeParams :: [TypeParamBase vn]+  , valBindParams     :: [PatternBase f vn]+  , valBindBody       :: ExpBase f vn+  , valBindDoc        :: Maybe DocComment+  , valBindLocation   :: SrcLoc+  } deriving instance Showable f vn => Show (ValBindBase f vn)  instance Located (ValBindBase f vn) where

@@ -18,7 +18,7 @@  import Control.Monad.Except import Control.Monad.Writer hiding (Sum)-import Data.List+import Data.List (isPrefixOf) import Data.Loc import Data.Maybe import Data.Either@@ -491,13 +491,36 @@                      },                TypeBind name' l tps' td' doc loc) ++entryPoint :: [Pattern] -> Maybe (TypeExp VName) -> StructType -> EntryPoint+entryPoint params orig_ret_te orig_ret =+  EntryPoint (map patternEntry params ++ more_params) rettype'+  where (more_params, rettype') =+          onRetType orig_ret_te orig_ret++        patternEntry (PatternParens p _) =+          patternEntry p+        patternEntry (PatternAscription _ tdecl _) =+          EntryType (unInfo (expandedType tdecl)) (Just (declaredType tdecl))+        patternEntry p =+          EntryType (patternStructType p) Nothing++        onRetType (Just (TEArrow _ t1_te t2_te _)) (Scalar (Arrow _ _ t1 t2)) =+          let (xs, y) = onRetType (Just t2_te) t2+          in (EntryType t1 (Just t1_te) : xs, y)+        onRetType _ (Scalar (Arrow _ _ t1 t2)) =+          let (xs, y) = onRetType Nothing t2+          in (EntryType t1 Nothing : xs, y)+        onRetType _ t =+          ([], EntryType t Nothing)+ checkValBind :: ValBindBase NoInfo Name -> TypeM (Env, ValBind) checkValBind (ValBind entry fname maybe_tdecl NoInfo tparams params body doc loc) = do   (fname', tparams', params', maybe_tdecl', rettype, retext, body') <-     checkFunDef (fname, maybe_tdecl, tparams, params, body, loc)    let (rettype_params, rettype') = unfoldFunType rettype-      entry' = Info (foldFunType (map patternStructType params') rettype) <$ entry+      entry' = Info (entryPoint params' maybe_tdecl' rettype) <$ entry    case entry' of     Just _

@@ -9,7 +9,7 @@  import Control.Monad.Except import Control.Monad.Writer hiding (Sum)-import Data.List+import Data.List (intersect) import Data.Loc import Data.Maybe import Data.Either

@@ -60,7 +60,7 @@ import Control.Monad.State import Control.Monad.RWS.Strict import Control.Monad.Identity-import Data.List+import Data.List (isPrefixOf, find) import Data.Loc import Data.Maybe import Data.Either

@@ -24,7 +24,7 @@ import Data.Bifunctor import Data.Char (isAscii) import Data.Either-import Data.List+import Data.List (isPrefixOf, foldl', find, (\\), nub, transpose, sort, group) import qualified Data.List.NonEmpty as NE import Data.Loc import Data.Maybe

@@ -27,7 +27,7 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor-import Data.List+import Data.List (foldl', sort, nub) import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M

@@ -41,7 +41,7 @@ import Control.Monad.RWS.Strict hiding (Sum) import Control.Monad.State import Data.Bifoldable (biany)-import Data.List+import Data.List (intersect) import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M@@ -545,7 +545,7 @@         unifyError usage mempty bcs $ "Type variable" <+> pprName vn <+>         "cannot be instantiated with type containing anonymous sizes:" </>         indent 2 (ppr tp) </>-        textwrap "This is usually because the size of an array returned by a higher-order function argument cannot be determined statically.  This can also be due to the return size beind a value parameter.  Add type annotation to clarify."+        textwrap "This is usually because the size of an array returned by a higher-order function argument cannot be determined statically.  This can also be due to the return size being a value parameter.  Add type annotation to clarify."      Just (Equality _) ->       equalityType usage tp'

@@ -4,7 +4,7 @@   ) where  import Data.Monoid-import Data.List+import Data.List (sortOn, intercalate) import Data.Loc  import Prelude

@@ -5,7 +5,7 @@ import Data.Maybe import Control.Exception import Control.Monad-import Data.List+import Data.List (sortOn) import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Encoding (setLocaleEncoding)