futhark 0.11.1 → 0.11.2

raw patch · 32 files changed

+216/−154 lines, 32 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• futhark.cabal +19/−17
• rts/c/opencl.h +0/−1
• rts/c/values.h +3/−1
• rts/python/__init__.py +0/−0
• rts/python/memory.py +9/−4
• src/Futhark/CLI/C.hs +1/−1
• src/Futhark/CLI/CSOpenCL.hs +1/−1
• src/Futhark/CLI/CSharp.hs +1/−1
• src/Futhark/CLI/CUDA.hs +1/−1
• src/Futhark/CLI/OpenCL.hs +1/−1
• src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +20/−0
• src/Futhark/CodeGen/Backends/COpenCL.hs +0/−1
• src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +1/−2
• src/Futhark/CodeGen/Backends/CSOpenCL.hs +5/−1
• src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs +1/−1
• src/Futhark/CodeGen/Backends/GenericCSharp.hs +1/−6
• src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +1/−1
• src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +2/−1
• src/Futhark/CodeGen/OpenCL/Heuristics.hs +57/−0
• src/Futhark/CodeGen/OpenCL/Kernels.hs +0/−57
• src/Futhark/Internalise.hs +11/−9
• src/Futhark/Internalise/Defunctionalise.hs +3/−3
• src/Futhark/Internalise/Defunctorise.hs +3/−1
• src/Futhark/Internalise/Monomorphise.hs +5/−4
• src/Futhark/Optimise/InPlaceLowering.hs +12/−8
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +6/−0
• src/Futhark/Pass/ExtractKernels/Interchange.hs +7/−4
• src/Futhark/Util.hs +11/−4
• src/Language/Futhark/Parser/Parser.y +4/−4
• src/Language/Futhark/Pretty.hs +2/−2
• src/Language/Futhark/Syntax.hs +8/−2
• src/Language/Futhark/TypeChecker.hs +20/−15

@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack ----- hash: eb85e7d5c7284742fdf0fda53a17074c98dc9526652f211fdabddb727e2beffa+-- hash: 1626fa99a399d6063ac04d34f5c73c94719161b2eab8876c29218c389c97d9e9  name:           futhark-version:        0.11.1+version:        0.11.2 synopsis:       An optimising compiler for a functional, array-oriented language. description:    Futhark is a small programming language designed to be compiled to                 efficient parallel code. It is a statically typed, data-parallel,@@ -22,14 +24,14 @@ license:        ISC license-file:   LICENSE build-type:     Simple-cabal-version:  >= 1.10 extra-source-files:-    futlib/array.fut-    futlib/functional.fut-    futlib/math.fut-    futlib/prelude.fut-    futlib/soacs.fut-    futlib/zip.fut+    rts/python/__init__.py+    rts/python/memory.py+    rts/python/opencl.py+    rts/python/panic.py+    rts/python/scalar.py+    rts/python/tuning.py+    rts/python/values.py     rts/c/cuda.h     rts/c/free_list.h     rts/c/lock.h@@ -47,12 +49,12 @@     rts/csharp/reader.cs     rts/csharp/scalar.cs     rts/futhark-doc/style.css-    rts/python/memory.py-    rts/python/opencl.py-    rts/python/panic.py-    rts/python/scalar.py-    rts/python/tuning.py-    rts/python/values.py+    futlib/array.fut+    futlib/functional.fut+    futlib/math.fut+    futlib/prelude.fut+    futlib/soacs.fut+    futlib/zip.fut  source-repository head   type: git@@ -134,7 +136,7 @@       Futhark.CodeGen.ImpGen.Kernels.Transpose       Futhark.CodeGen.ImpGen.OpenCL       Futhark.CodeGen.ImpGen.Sequential-      Futhark.CodeGen.OpenCL.Kernels+      Futhark.CodeGen.OpenCL.Heuristics       Futhark.CodeGen.SetDefaultSpace       Futhark.Compiler       Futhark.Compiler.CLI

@@ -766,7 +766,6 @@ }  int opencl_alloc(struct opencl_context *ctx, size_t min_size, const char *tag, cl_mem *mem_out) {-  assert(min_size >= 0);   if (min_size < sizeof(int)) {     min_size = sizeof(int);   }

@@ -790,7 +790,9 @@   fputc((char)BINARY_FORMAT_VERSION, out);   fwrite(&rank, sizeof(int8_t), 1, out);   fputs(elem_type->binname, out);-  fwrite(shape, sizeof(int64_t), rank, out);+  if (shape != NULL) {+    fwrite(shape, sizeof(int64_t), rank, out);+  }    if (IS_BIG_ENDIAN) {     for (int64_t i = 0; i < num_elems; i++) {

@@ -19,14 +19,19 @@ def unwrapArray(x):   return normaliseArray(x).ctypes.data_as(ct.POINTER(ct.c_byte)) -def createArray(x, dim):-  return np.ctypeslib.as_array(x, shape=dim)+def createArray(x, shape):+  # HACK: np.ctypeslib.as_array may fail if the shape contains zeroes,+  # for some reason.+  if any(map(lambda x: x == 0, shape)):+      return np.ndarray(shape, dtype=x._type_)+  else:+      return np.ctypeslib.as_array(x, shape=shape)  def indexArray(x, offset, bt, nptype):-  return nptype(addressOffset(x, offset, bt)[0])+  return nptype(addressOffset(x, offset*ct.sizeof(bt), bt)[0])  def writeScalarArray(x, offset, v):-  ct.memmove(ct.addressof(x.contents)+int(offset), ct.addressof(v), ct.sizeof(v))+  ct.memmove(ct.addressof(x.contents)+int(offset)*ct.sizeof(v), ct.addressof(v), ct.sizeof(v))  # An opaque Futhark value. class opaque(object):

@@ -29,7 +29,7 @@            ToExecutable -> do              liftIO $ writeFile cpath $ SequentialC.asExecutable cprog              ret <- liftIO $ runProgramWithExitCode "gcc"-                    [cpath, "-O3", "-std=c99", "-lm", "-o", outpath] ""+                    [cpath, "-O3", "-std=c99", "-lm", "-o", outpath] mempty              case ret of                Left err ->                  externalErrorS $ "Failed to run gcc: " ++ show err

@@ -34,7 +34,7 @@             ToLibrary -> return ()             ToExecutable -> do               ret <- liftIO $ runProgramWithExitCode "csc"-                ["-out:" ++ outpath, "-lib:"++mono_libs, "-r:Cloo.clSharp.dll,Mono.Options.dll", cspath, "/unsafe"] ""+                ["-out:" ++ outpath, "-lib:"++mono_libs, "-r:Cloo.clSharp.dll,Mono.Options.dll", cspath, "/unsafe"] mempty               case ret of                 Left err ->                   externalErrorS $ "Failed to run csc: " ++ show err

@@ -38,7 +38,7 @@                  , "-r:Cloo.clSharp.dll"                  , "-r:Mono.Options.dll"                  , cspath-                 , "/unsafe"] ""+                 , "/unsafe"] mempty                case ret of                  Left err ->                    externalErrorS $ "Failed to run csc: " ++ show err

@@ -32,7 +32,7 @@              liftIO $ writeFile cpath $ CCUDA.asExecutable cprog              let args = [cpath, "-O", "-std=c99", "-lm", "-o", outpath]                         ++ extra_options-             ret <- liftIO $ runProgramWithExitCode "gcc" args ""+             ret <- liftIO $ runProgramWithExitCode "gcc" args mempty              case ret of                Left err ->                  externalErrorS $ "Failed to run gcc: " ++ show err

@@ -37,7 +37,7 @@            ToExecutable -> do              liftIO $ writeFile cpath $ COpenCL.asExecutable cprog              ret <- liftIO $ runProgramWithExitCode "gcc"-                    ([cpath, "-O", "-std=c99", "-lm", "-o", outpath] ++ extra_options) ""+                    ([cpath, "-O", "-std=c99", "-lm", "-o", outpath] ++ extra_options) mempty              case ret of                Left err ->                  externalErrorS $ "Failed to run gcc: " ++ show err

@@ -195,6 +195,26 @@                              return 0;                            }                          }++                         if (strcmp(size_name, "default_block_size") == 0) {+                           cfg->cu_cfg.default_block_size = size_value;+                           return 0;+                         }++                         if (strcmp(size_name, "default_grid_size") == 0) {+                           cfg->cu_cfg.default_grid_size = size_value;+                           return 0;+                         }++                         if (strcmp(size_name, "default_threshold") == 0) {+                           cfg->cu_cfg.default_threshold = size_value;+                           return 0;+                         }++                         if (strcmp(size_name, "default_tile_size") == 0) {+                           cfg->cu_cfg.default_tile_size = size_value;+                           return 0;+                         }                          return 1;                        }|])   return cfg

@@ -142,7 +142,6 @@                       , optionShortName = Nothing                       , optionArgument = RequiredArgument "FILE"                       , optionAction = [C.cstm|{-                          char *fname = optarg;                           char *ret = load_tuning_file(optarg, cfg, (int(*)(void*, const char*, size_t))                                                                     futhark_context_config_set_size);                           if (ret != NULL) {

@@ -14,7 +14,7 @@  import Futhark.CodeGen.ImpCode.OpenCL import qualified Futhark.CodeGen.Backends.GenericC as GC-import Futhark.CodeGen.OpenCL.Kernels+import Futhark.CodeGen.OpenCL.Heuristics import Futhark.Util (chunk, zEncodeString)  generateBoilerplate :: String -> String -> [String] -> [PrimType]@@ -237,7 +237,6 @@                           [(0::Int)..] $ M.keys sizes    GC.libDecl [C.cedecl|static void init_context_early(struct $id:cfg *cfg, struct $id:ctx* ctx) {-                     typename cl_int error;                      ctx->opencl.cfg = cfg->opencl;                      ctx->detail_memory = cfg->opencl.debugging;                      ctx->debugging = cfg->opencl.debugging;

@@ -114,8 +114,12 @@                       , optionArgument = RequiredArgument                       , optionAction = [Escape "FutharkConfigSetSize(ref Cfg, optarg);"]                       }+             , Option { optionLongName = "tuning"+                      , optionShortName = Nothing+                      , optionArgument = RequiredArgument+                      , optionAction = [Escape "FutharkConfigLoadTuning(ref Cfg, optarg);"]+                      }              ]-  callKernel :: CS.OpCompiler Imp.OpenCL () callKernel (Imp.GetSize v key) =

@@ -10,7 +10,7 @@ import Futhark.CodeGen.ImpCode.OpenCL hiding (Index, If) import Futhark.CodeGen.Backends.GenericCSharp as CS import Futhark.CodeGen.Backends.GenericCSharp.AST as AST-import Futhark.CodeGen.OpenCL.Kernels+import Futhark.CodeGen.OpenCL.Heuristics import Futhark.Util (zEncodeString)  intT, longT, stringT, intArrayT, stringArrayT :: CSType

@@ -379,13 +379,8 @@          , optionShortName = Just 'e'          , optionArgument = RequiredArgument          , optionAction =-           [ Reassign (Var "EntryPoint") $ Var "optarg" ]+             [ Reassign (Var "EntryPoint") $ Var "optarg" ]          }-  , Option { optionLongName = "tuning"-           , optionShortName = Nothing-           , optionArgument = RequiredArgument-           , optionAction = [Escape "FutharkConfigLoadTuning(ref Cfg, optarg);"]-           }   ]  -- | The class generated by the code generator must have a

@@ -12,7 +12,7 @@ import NeatInterpolation (text)  import Futhark.CodeGen.ImpCode.OpenCL (PrimType(..), SizeClass(..))-import Futhark.CodeGen.OpenCL.Kernels+import Futhark.CodeGen.OpenCL.Heuristics import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.Util.Pretty (pretty, prettyText) 

@@ -238,7 +238,8 @@ typedef uint uint32_t; typedef ulong uint64_t; -$esc:("#define ALIGNED_LOCAL_MEMORY(m,size) __local unsigned char m[size] __attribute__ ((align))")+// We declare the shared memory array as int64_t to force alignment.+$esc:("#define ALIGNED_LOCAL_MEMORY(m,size) __local int64_t m[((size + 7) & ~7)/8]")  // NVIDIAs OpenCL does not create device-wide memory fences (see #734), so we // use inline assembly if we detect we are on an NVIDIA GPU.

@@ -0,0 +1,57 @@+module Futhark.CodeGen.OpenCL.Heuristics+       ( SizeHeuristic (..)+       , DeviceType (..)+       , WhichSize (..)+       , HeuristicValue (..)+       , sizeHeuristicsTable+       )+       where++-- Some OpenCL platforms have a SIMD/warp/wavefront-based execution+-- model that execute groups of threads in lockstep, permitting us to+-- perform cross-thread synchronisation within each such group without+-- the use of barriers.  Unfortunately, there seems to be no reliable+-- way to query these sizes at runtime.  Instead, we use this table to+-- figure out which size we should use for a specific platform and+-- device.  If nothing matches here, the wave size should be set to+-- one.+--+-- We also use this to select reasonable default group sizes and group+-- counts.++-- | The type of OpenCL device that this heuristic applies to.+data DeviceType = DeviceCPU | DeviceGPU++-- | The value supplies by a heuristic can be a constant, or inferred+-- from some device information.+data HeuristicValue = HeuristicConst Int+                    | HeuristicDeviceInfo String++-- | A size that can be assigned a default.+data WhichSize = LockstepWidth | NumGroups | GroupSize | TileSize | Threshold++-- | A heuristic for setting the default value for something.+data SizeHeuristic =+    SizeHeuristic { platformName :: String+                  , deviceType :: DeviceType+                  , heuristicSize :: WhichSize+                  , heuristicValue :: HeuristicValue+                  }++-- | All of our heuristics.+sizeHeuristicsTable :: [SizeHeuristic]+sizeHeuristicsTable =+  [ SizeHeuristic "NVIDIA CUDA" DeviceGPU LockstepWidth $ HeuristicConst 32+  , SizeHeuristic "AMD Accelerated Parallel Processing" DeviceGPU LockstepWidth $ HeuristicConst 32+  , SizeHeuristic "" DeviceGPU LockstepWidth $ HeuristicConst 1+  , SizeHeuristic "" DeviceGPU NumGroups $ HeuristicConst 256+  , SizeHeuristic "" DeviceGPU GroupSize $ HeuristicConst 256+  , SizeHeuristic "" DeviceGPU TileSize $ HeuristicConst 32+  , SizeHeuristic "" DeviceGPU Threshold $ HeuristicConst $ 32*1024++  , SizeHeuristic "" DeviceCPU LockstepWidth $ HeuristicConst 1+  , SizeHeuristic "" DeviceCPU NumGroups $ HeuristicDeviceInfo "MAX_COMPUTE_UNITS"+  , SizeHeuristic "" DeviceCPU GroupSize $ HeuristicConst 32+  , SizeHeuristic "" DeviceCPU TileSize $ HeuristicConst 4+  , SizeHeuristic "" DeviceCPU Threshold $ HeuristicDeviceInfo "MAX_COMPUTE_UNITS"+  ]

@@ -1,57 +0,0 @@-module Futhark.CodeGen.OpenCL.Kernels-       ( SizeHeuristic (..)-       , DeviceType (..)-       , WhichSize (..)-       , HeuristicValue (..)-       , sizeHeuristicsTable-       )-       where---- Some OpenCL platforms have a SIMD/warp/wavefront-based execution--- model that execute groups of threads in lockstep, permitting us to--- perform cross-thread synchronisation within each such group without--- the use of barriers.  Unfortunately, there seems to be no reliable--- way to query these sizes at runtime.  Instead, we use this table to--- figure out which size we should use for a specific platform and--- device.  If nothing matches here, the wave size should be set to--- one.------ We also use this to select reasonable default group sizes and group--- counts.---- | The type of OpenCL device that this heuristic applies to.-data DeviceType = DeviceCPU | DeviceGPU---- | The value supplies by a heuristic can be a constant, or inferred--- from some device information.-data HeuristicValue = HeuristicConst Int-                    | HeuristicDeviceInfo String---- | A size that can be assigned a default.-data WhichSize = LockstepWidth | NumGroups | GroupSize | TileSize | Threshold---- | A heuristic for setting the default value for something.-data SizeHeuristic =-    SizeHeuristic { platformName :: String-                  , deviceType :: DeviceType-                  , heuristicSize :: WhichSize-                  , heuristicValue :: HeuristicValue-                  }---- | All of our heuristics.-sizeHeuristicsTable :: [SizeHeuristic]-sizeHeuristicsTable =-  [ SizeHeuristic "NVIDIA CUDA" DeviceGPU LockstepWidth $ HeuristicConst 32-  , SizeHeuristic "AMD Accelerated Parallel Processing" DeviceGPU LockstepWidth $ HeuristicConst 64-  , SizeHeuristic "" DeviceGPU LockstepWidth $ HeuristicConst 1-  , SizeHeuristic "" DeviceGPU NumGroups $ HeuristicConst 256-  , SizeHeuristic "" DeviceGPU GroupSize $ HeuristicConst 256-  , SizeHeuristic "" DeviceGPU TileSize $ HeuristicConst 32-  , SizeHeuristic "" DeviceGPU Threshold $ HeuristicConst $ 32*1024--  , SizeHeuristic "" DeviceCPU LockstepWidth $ HeuristicConst 1-  , SizeHeuristic "" DeviceCPU NumGroups $ HeuristicDeviceInfo "MAX_COMPUTE_UNITS"-  , SizeHeuristic "" DeviceCPU GroupSize $ HeuristicConst 32-  , SizeHeuristic "" DeviceCPU TileSize $ HeuristicConst 4-  , SizeHeuristic "" DeviceCPU Threshold $ HeuristicDeviceInfo "MAX_COMPUTE_UNITS"-  ]

@@ -115,7 +115,8 @@             applyRetType rettype' all_params)    bindFunction fname info-  when entry $ generateEntryPoint fb+  case entry of Just (Info entry') -> generateEntryPoint entry' fb+                Nothing -> return ()    where     -- | Recompute existential sizes to start from zero.@@ -149,8 +150,8 @@ allDimsFreshInPat (PatternLit e (Info t) loc) =   PatternLit e <$> (Info <$> allDimsFreshInType t) <*> pure loc -generateEntryPoint :: E.ValBind -> InternaliseM ()-generateEntryPoint (E.ValBind _ ofname retdecl (Info rettype) _ params _ _ loc) = do+generateEntryPoint :: E.StructType -> E.ValBind -> InternaliseM ()+generateEntryPoint ftype (E.ValBind _ ofname retdecl (Info rettype) _ params _ _ loc) = do   -- We replace all shape annotations, so there should be no constant   -- parameters here.   params_fresh <- mapM allDimsFreshInPat params@@ -158,7 +159,8 @@                 mconcat $ map E.patternDimNames params_fresh   bindingParams tparams params_fresh $ \_ shapeparams params' -> do     (entry_rettype, _) <- internaliseEntryReturnType $ anyDimShapeAnnotations rettype-    let entry' = entryPoint (zip params params') (retdecl, rettype, entry_rettype)+    let (e_paramts, e_rettype) = E.unfoldFunType ftype+        entry' = entryPoint (zip3 params e_paramts params') (retdecl, e_rettype, entry_rettype)         args = map (I.Var . I.paramName) $ concat params'      entry_body <- insertStmsM $ do@@ -172,7 +174,7 @@       (concat entry_rettype)       (shapeparams ++ concat params') entry_body -entryPoint :: [(E.Pattern,[I.FParam])]+entryPoint :: [(E.Pattern, E.StructType, [I.FParam])]            -> (Maybe (E.TypeExp VName), E.StructType, [[I.TypeBase ExtShape Uniqueness]])            -> EntryPoint entryPoint params (retdecl, eret, crets) =@@ -180,9 +182,9 @@    case isTupleRecord eret of      Just ts -> concatMap entryPointType $ zip3 retdecls ts crets      _       -> entryPointType (retdecl, eret, concat crets))-  where preParam (p_pat, ps) = (paramOuterType p_pat,-                                E.patternStructType p_pat,-                                staticShapes $ map I.paramDeclType ps)+  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@@ -465,7 +467,7 @@   internalisePat desc pat e body loc (internaliseExp desc)  internaliseExp desc (E.LetFun ofname (tparams, params, retdecl, Info rettype, body) letbody loc) = do-  internaliseValBind $ E.ValBind False ofname retdecl (Info rettype) tparams params body Nothing loc+  internaliseValBind $ E.ValBind Nothing ofname retdecl (Info rettype) tparams params body Nothing loc   internaliseExp desc letbody  internaliseExp desc (E.DoLoop mergepat mergeexp form loopbody loc) = do

@@ -587,7 +587,7 @@   where dims' = map (flip TypeParamDim noLoc) dims         rettype_st = anyDimShapeAnnotations $ toStruct rettype         dec = ValBind-          { valBindEntryPoint = False+          { valBindEntryPoint = Nothing           , valBindName       = fname           , valBindRetDecl    = Nothing           , valBindRetType    = Info rettype_st@@ -816,13 +816,13 @@ defuncValBind :: ValBind -> DefM (ValBind, Env, Bool)  -- Eta-expand entry points with a functional return type.-defuncValBind (ValBind True name _ (Info rettype) tparams params body _ loc)+defuncValBind (ValBind entry@Just{} name _ (Info rettype) tparams params body _ loc)   | (rettype_ps, rettype') <- unfoldFunType rettype,     not $ null rettype_ps = do       (body_pats, body', _) <- etaExpand body       -- FIXME: we should also handle non-constant size annotations       -- here.-      defuncValBind $ ValBind True name Nothing+      defuncValBind $ ValBind entry name Nothing         (Info $ onlyConstantDims rettype')         tparams (params <> body_pats) body' Nothing loc   where onlyConstantDims = bimap onDim id

@@ -304,7 +304,9 @@      maybeHideEntryPoint (ValDec vdec) =       ValDec vdec { valBindEntryPoint =-                      valBindEntryPoint vdec && permit_entry_points }+                      if permit_entry_points+                      then valBindEntryPoint vdec+                      else Nothing  }     maybeHideEntryPoint d = d  transformProg :: MonadFreshNames m => Imports -> m [Dec]

@@ -35,6 +35,7 @@ import           Data.Bifunctor import           Data.Loc import qualified Data.Map.Strict as M+import           Data.Maybe import qualified Data.Set as S import qualified Data.Sequence as Seq import           Data.Foldable@@ -451,7 +452,7 @@                                   }          toValBinding t_shape_params name' params'' rettype' body'' =-          ValBind { valBindEntryPoint = False+          ValBind { valBindEntryPoint = Nothing                   , valBindName       = name'                   , valBindRetDecl    = retdecl                   , valBindRetType    = Info rettype'@@ -545,13 +546,13 @@  transformValBind :: ValBind -> MonoM Env transformValBind valbind = do-  valbind' <- toPolyBinding <$> removeTypeVariables (valBindEntryPoint valbind) valbind-  when (valBindEntryPoint valbind) $ do+  valbind' <- toPolyBinding <$> removeTypeVariables (isJust (valBindEntryPoint valbind)) valbind+  when (isJust $ valBindEntryPoint valbind) $ do     t <- removeTypeVariablesInType $ removeShapeAnnotations $ foldFunType          (map patternStructType (valBindParams valbind)) $          unInfo $ valBindRetType valbind     (name, valbind'') <- monomorphizeBinding True valbind' t-    tell $ Seq.singleton (name, valbind'' { valBindEntryPoint = True})+    tell $ Seq.singleton (name, valbind'' { valBindEntryPoint = valBindEntryPoint valbind})     addLifted (valBindName valbind) t name   return mempty { envPolyBindings = M.singleton (valBindName valbind) valbind' } 

@@ -10,11 +10,12 @@ -- minimising memory copies.  As an example, consider this program: -- -- @---   loop (r = r0) = for i < n do---     let a = r[i] in---     let r[i] = a * i in---     r---     in+--   let r =+--     loop (r1 = r0) = for i < n do+--       let a = r1[i] in+--       let r1[i] = a * i in+--       r1+--       in --   ... --   let x = y with [k] <- r in --   ...@@ -48,7 +49,7 @@ --    (4) If @x@ is consumed at a point after the loop, @r@ must not --    be used after that point. -----    (5) The size of @r@ is invariant inside the loop.+--    (5) The size of @r1@ is invariant inside the loop. -- --    (6) The value @r@ must come from something that we can actually --    optimise (e.g. not a function parameter).@@ -56,8 +57,11 @@ --    (7) @y@ (or its aliases) may not be used inside the body of the --    loop. ----- FIXME: the implementation is not finished yet.  Specifically, the--- above conditions are not really checked.+--    (8) The result of the loop may not alias the merge parameter+--    @r1@.+--+-- FIXME: the implementation is not finished yet.  Specifically, not+-- all of the above conditions are checked. module Futhark.Optimise.InPlaceLowering        (          inPlaceLowering

@@ -135,7 +135,13 @@   --   -- We also check that the merge parameters we work with have   -- loop-invariant shapes.++  -- Safety condition (8).+  forM_ (zip val $ bodyAliases body) $ \((p, _), als) ->+    guard $ not $ paramName p `S.member` als+   mk_in_place_map <- summariseLoop updates usedInBody resmap val+   Just $ do     in_place_map <- mk_in_place_map     (val',prebnds,postbnds) <- mkMerges in_place_map

@@ -35,9 +35,10 @@   Let pat (defAux ()) $ DoLoop [] merge form body  interchangeLoop :: (MonadBinder m, LocalScope SOACS m) =>-                   SeqLoop -> LoopNesting+                   (VName -> Maybe VName) -> SeqLoop -> LoopNesting                 -> m SeqLoop interchangeLoop+  isMapParameter   (SeqLoop perm loop_pat merge form body)   (MapNesting pat cs w params_and_arrs) = do     merge_expanded <-@@ -80,8 +81,7 @@             return $ Just (param, arr)          expandedInit _ (Var v)-          | Just (_, arr) <--              find ((==v).paramName.fst) params_and_arrs =+          | Just arr <- isMapParameter v =               return $ Var arr         expandedInit param_name se =           letSubExp (param_name <> "_expanded_init") $@@ -124,8 +124,11 @@                  -> m (Stms SOACS) interchangeLoops nest loop = do   (loop', bnds) <--    runBinder $ foldM interchangeLoop loop $ reverse $ kernelNestLoops nest+    runBinder $ foldM (interchangeLoop isMapParameter) loop $ reverse $ kernelNestLoops nest   return $ bnds <> oneStm (seqLoopStm loop')+  where isMapParameter v =+          fmap snd $ find ((==v) . paramName . fst) $+          concatMap loopNestingParamsAndArrs $ kernelNestLoops nest  data Branch = Branch [Int] Pattern SubExp Body Body (IfAttr (BranchType SOACS)) 

@@ -39,6 +39,10 @@ import Control.Concurrent import Control.Exception import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T import Data.Char import Data.List import Data.Either@@ -46,7 +50,7 @@ import System.Environment import System.IO.Unsafe import qualified System.Directory.Tree as Dir-import System.Process+import System.Process.ByteString import System.Exit import qualified System.FilePath.Posix as Posix import qualified System.FilePath as Native@@ -148,12 +152,15 @@  -- | Like 'readProcessWithExitCode', but also wraps exceptions when -- the indicated binary cannot be launched, or some other exception is--- thrown.-runProgramWithExitCode :: FilePath -> [String] -> String+-- thrown.  Also does shenanigans to handle improperly encoded outputs.+runProgramWithExitCode :: FilePath -> [String] -> BS.ByteString                        -> IO (Either IOException (ExitCode, String, String)) runProgramWithExitCode exe args inp =-  (Right <$> readProcessWithExitCode exe args inp)+  (Right . postprocess <$> readProcessWithExitCode exe args inp)   `catch` \e -> return (Left e)+  where decode = T.unpack . T.decodeUtf8With T.lenientDecode+        postprocess (err, stdout, stderr) =+          (err, decode stdout, decode stderr)  -- | Every non-directory file contained in a directory tree. directoryContents :: FilePath -> IO [FilePath]

@@ -380,22 +380,22 @@ Val    :: { ValBindBase NoInfo Name } Val     : let BindingId TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp           { let (name, _) = $2-            in ValBind (name==defaultEntryPoint) name (fmap declaredType $5) NoInfo+            in ValBind (if name==defaultEntryPoint then Just NoInfo else Nothing) name (fmap declaredType $5) NoInfo                $3 $4 $7 Nothing (srcspan $1 $>)           }          | entry BindingId TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp           { let (name, loc) = $2-            in ValBind True name (fmap declaredType $5) NoInfo+            in ValBind (Just NoInfo) name (fmap declaredType $5) NoInfo                $3 $4 $7 Nothing (srcspan $1 $>) }          | let FunParam BindingBinOp FunParam maybeAscription(TypeExpDecl) '=' Exp-          { ValBind False $3 (fmap declaredType $5) NoInfo [] [$2,$4] $7 Nothing (srcspan $1 $>)+          { ValBind Nothing $3 (fmap declaredType $5) NoInfo [] [$2,$4] $7 Nothing (srcspan $1 $>)           }          | let BindingUnOp TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp           { let name = $2-            in ValBind (name==defaultEntryPoint) name (fmap declaredType $5) NoInfo+            in ValBind Nothing name (fmap declaredType $5) NoInfo                $3 $4 $7 Nothing (srcspan $1 $>)           } 

@@ -371,8 +371,8 @@     text fun <+> pprName name <+>     spread (map ppr tparams ++ map ppr args) <> retdecl' <> text " =" </>     indent 2 (ppr body)-    where fun | entry     = "entry"-              | otherwise = "let"+    where fun | isJust entry = "entry"+              | otherwise    = "let"           retdecl' = case (ppr <$> unAnnot rettype) `mplus` (ppr <$> retdecl) of                        Just rettype' -> text ":" <+> rettype'                        Nothing       -> mempty

@@ -772,8 +772,14 @@   locOf (DocComment _ loc) = locOf loc  -- | Function Declarations-data ValBindBase f vn = ValBind { valBindEntryPoint :: Bool-                                -- ^ True if this function is an entry point.+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

@@ -473,31 +473,36 @@   (fname', tparams', params', maybe_tdecl', rettype, body') <-     checkFunDef (fname, maybe_tdecl, tparams, params, body, loc) -  when (entry && any isTypeParam tparams') $-    throwError $ TypeError loc "Entry point functions may not be polymorphic."-   let (rettype_params, rettype') = unfoldFunType rettype-  when (entry && (any (not . patternOrderZero) params' ||-                  any (not . orderZero) rettype_params ||-                  not (orderZero rettype'))) $-    throwError $ TypeError loc "Entry point functions may not be higher-order."+      entry' = Info (foldFunType (map patternStructType params') rettype) <$ entry -  case (entry, filter nastyParameter params') of-    (True, p : _) -> warn loc $ "Entry point parameter\n\n  " <>-                     pretty p <> "\n\nwill have an opaque type, so the entry point will likely not be callable."-    _ -> return ()+  case entry' of+    Just _+      | any isTypeParam tparams' ->+          throwError $ TypeError loc "Entry point functions may not be polymorphic." -  when (entry && nastyReturnType maybe_tdecl' rettype) $-    warn loc $ "Entry point return type\n\n  " <>-    pretty rettype <> "\n\nwill have an opaque type, so the result will likely not be usable."+      | any (not . patternOrderZero) params'+        || any (not . orderZero) rettype_params+        || not (orderZero rettype') ->+          throwError $ TypeError loc "Entry point functions may not be higher-order." +      | p : _ <- filter nastyParameter params' ->+          warn loc $ "Entry point parameter\n\n  " <>+          pretty p <> "\n\nwill have an opaque type, so the entry point will likely not be callable."++      | nastyReturnType maybe_tdecl' rettype ->+          warn loc $ "Entry point return type\n\n  " <>+          pretty rettype <> "\n\nwill have an opaque type, so the result will likely not be usable."++    _ -> return ()+   return (mempty { envVtable =                      M.singleton fname' $                      BoundV tparams' $ foldr (uncurry (Arrow ()) . patternParam) rettype params'                  , envNameMap =                      M.singleton (Term, fname) $ qualName fname'                  },-           ValBind entry fname' maybe_tdecl' (Info rettype) tparams' params' body' doc loc)+           ValBind entry' fname' maybe_tdecl' (Info rettype) tparams' params' body' doc loc)  nastyType :: Monoid als => TypeBase dim als -> Bool nastyType Prim{} = False