diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -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 diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.h @@ -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); } diff --git a/rts/c/values.h b/rts/c/values.h --- a/rts/c/values.h +++ b/rts/c/values.h @@ -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++) { diff --git a/rts/python/__init__.py b/rts/python/__init__.py new file mode 100644 --- /dev/null +++ b/rts/python/__init__.py diff --git a/rts/python/memory.py b/rts/python/memory.py --- a/rts/python/memory.py +++ b/rts/python/memory.py @@ -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): diff --git a/src/Futhark/CLI/C.hs b/src/Futhark/CLI/C.hs --- a/src/Futhark/CLI/C.hs +++ b/src/Futhark/CLI/C.hs @@ -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 diff --git a/src/Futhark/CLI/CSOpenCL.hs b/src/Futhark/CLI/CSOpenCL.hs --- a/src/Futhark/CLI/CSOpenCL.hs +++ b/src/Futhark/CLI/CSOpenCL.hs @@ -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 diff --git a/src/Futhark/CLI/CSharp.hs b/src/Futhark/CLI/CSharp.hs --- a/src/Futhark/CLI/CSharp.hs +++ b/src/Futhark/CLI/CSharp.hs @@ -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 diff --git a/src/Futhark/CLI/CUDA.hs b/src/Futhark/CLI/CUDA.hs --- a/src/Futhark/CLI/CUDA.hs +++ b/src/Futhark/CLI/CUDA.hs @@ -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 diff --git a/src/Futhark/CLI/OpenCL.hs b/src/Futhark/CLI/OpenCL.hs --- a/src/Futhark/CLI/OpenCL.hs +++ b/src/Futhark/CLI/OpenCL.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -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) { diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -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; diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL.hs b/src/Futhark/CodeGen/Backends/CSOpenCL.hs --- a/src/Futhark/CodeGen/Backends/CSOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/CSOpenCL.hs @@ -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) = diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp.hs b/src/Futhark/CodeGen/Backends/GenericCSharp.hs --- a/src/Futhark/CodeGen/Backends/GenericCSharp.hs +++ b/src/Futhark/CodeGen/Backends/GenericCSharp.hs @@ -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 diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs @@ -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) diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs @@ -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. diff --git a/src/Futhark/CodeGen/OpenCL/Heuristics.hs b/src/Futhark/CodeGen/OpenCL/Heuristics.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/OpenCL/Heuristics.hs @@ -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" + ] diff --git a/src/Futhark/CodeGen/OpenCL/Kernels.hs b/src/Futhark/CodeGen/OpenCL/Kernels.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/OpenCL/Kernels.hs +++ /dev/null @@ -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" - ] diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -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 diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -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 diff --git a/src/Futhark/Internalise/Defunctorise.hs b/src/Futhark/Internalise/Defunctorise.hs --- a/src/Futhark/Internalise/Defunctorise.hs +++ b/src/Futhark/Internalise/Defunctorise.hs @@ -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] diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -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' } diff --git a/src/Futhark/Optimise/InPlaceLowering.hs b/src/Futhark/Optimise/InPlaceLowering.hs --- a/src/Futhark/Optimise/InPlaceLowering.hs +++ b/src/Futhark/Optimise/InPlaceLowering.hs @@ -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 diff --git a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs --- a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +++ b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels/Interchange.hs b/src/Futhark/Pass/ExtractKernels/Interchange.hs --- a/src/Futhark/Pass/ExtractKernels/Interchange.hs +++ b/src/Futhark/Pass/ExtractKernels/Interchange.hs @@ -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)) diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -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] diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -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 $>) } diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -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 diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -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 diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs --- a/src/Language/Futhark/TypeChecker.hs +++ b/src/Language/Futhark/TypeChecker.hs @@ -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