diff --git a/docs/index.rst b/docs/index.rst --- a/docs/index.rst +++ b/docs/index.rst @@ -15,8 +15,8 @@ better served by reading `Parallel Programming in Futhark `_ first. -Documentation for the included basis library is also `available online -`_. +Documentation for the built-in prelude is also `available online +`_. The particularly interested reader may also want to peruse the `publications `_, or diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: futhark -version: 0.17.2 +version: 0.17.3 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -97,8 +97,8 @@ compileCAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem compileCAction fcfg mode outpath = Action - { actionName = "Compile to OpenCL", - actionDescription = "Compile to OpenCL", + { actionName = "Compile to to sequential C", + actionDescription = "Compile to sequential C", actionProcedure = helper } where diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -213,20 +213,21 @@ -- | Run the benchmark program on the indicated dataset. benchmarkDataset :: RunOptions -> + FutharkExe -> FilePath -> T.Text -> Values -> Maybe Success -> FilePath -> IO (Either T.Text ([RunResult], T.Text)) -benchmarkDataset opts program entry input_spec expected_spec ref_out = +benchmarkDataset opts futhark program entry input_spec expected_spec ref_out = -- We store the runtime in a temporary file. withSystemTempFile "futhark-bench" $ \tmpfile h -> do hClose h -- We will be writing and reading this ourselves. - input <- getValuesBS dir input_spec + input <- getValuesBS futhark dir input_spec let getValuesAndBS (SuccessValues vs) = do - vs' <- getValues dir vs - bs <- getValuesBS dir vs + vs' <- getValues futhark dir vs + bs <- getValuesBS futhark dir vs return (LBS.toStrict bs, vs') getValuesAndBS SuccessGenerateValues = getValuesAndBS $ SuccessValues $ InFile ref_out @@ -313,7 +314,7 @@ prepareBenchmarkProgram concurrency opts program cases = do let futhark = compFuthark opts - ref_res <- runExceptT $ ensureReferenceOutput concurrency futhark "c" program cases + ref_res <- runExceptT $ ensureReferenceOutput concurrency (FutharkExe futhark) "c" program cases case ref_res of Left err -> return $ diff --git a/src/Futhark/CLI/Autotune.hs b/src/Futhark/CLI/Autotune.hs --- a/src/Futhark/CLI/Autotune.hs +++ b/src/Futhark/CLI/Autotune.hs @@ -88,8 +88,8 @@ type DatasetName = String -prepare :: AutotuneOptions -> FilePath -> IO [(DatasetName, RunDataset, T.Text)] -prepare opts prog = do +prepare :: AutotuneOptions -> FutharkExe -> FilePath -> IO [(DatasetName, RunDataset, T.Text)] +prepare opts futhark prog = do spec <- testSpecFromFileOrDie prog copts <- compileOptions opts @@ -143,6 +143,7 @@ either (Left . T.unpack) (Right . bestRuntime) <$> benchmarkDataset ropts + futhark prog entry_point (runInput trun) @@ -344,8 +345,10 @@ tune :: AutotuneOptions -> FilePath -> IO Path tune opts prog = do + futhark <- fmap FutharkExe $ maybe getExecutablePath return $ optFuthark opts + putStrLn $ "Compiling " ++ prog ++ "..." - datasets <- prepare opts prog + datasets <- prepare opts futhark prog forest <- thresholdForest prog when (optVerbose opts > 0) $ diff --git a/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs --- a/src/Futhark/CLI/Bench.hs +++ b/src/Futhark/CLI/Bench.hs @@ -86,10 +86,12 @@ putStrLn $ "Reporting average runtime of " ++ show (optRuns opts) ++ " runs for each dataset." + futhark <- FutharkExe . compFuthark <$> compileOptions opts + results <- concat <$> mapM - (runBenchmark opts) + (runBenchmark opts futhark) (sortBy (comparing fst) compiled_benchmarks) case optJSON opts of Nothing -> return () @@ -159,8 +161,8 @@ where hasRuns (InputOutputs _ runs) = not $ null runs -runBenchmark :: BenchOptions -> (FilePath, [InputOutputs]) -> IO [BenchResult] -runBenchmark opts (program, cases) = mapM forInputOutputs $ filter relevant cases +runBenchmark :: BenchOptions -> FutharkExe -> (FilePath, [InputOutputs]) -> IO [BenchResult] +runBenchmark opts futhark (program, cases) = mapM forInputOutputs $ filter relevant cases where forInputOutputs (InputOutputs entry_name runs) = do (tuning_opts, tuning_desc) <- determineTuning (optTuning opts) program @@ -172,7 +174,7 @@ optExtraOptions opts ++ tuning_opts } BenchResult program' . catMaybes - <$> mapM (runBenchmarkCase opts' program entry_name pad_to) runs + <$> mapM (runBenchmarkCase opts' futhark program entry_name pad_to) runs where program' = if entry_name == "main" @@ -253,17 +255,18 @@ runBenchmarkCase :: BenchOptions -> + FutharkExe -> FilePath -> T.Text -> Int -> TestRun -> IO (Maybe DataResult) -runBenchmarkCase _ _ _ _ (TestRun _ _ RunTimeFailure {} _ _) = +runBenchmarkCase _ _ _ _ _ (TestRun _ _ RunTimeFailure {} _ _) = return Nothing -- Not our concern, we are not a testing tool. -runBenchmarkCase opts _ _ _ (TestRun tags _ _ _ _) +runBenchmarkCase opts _ _ _ _ (TestRun tags _ _ _ _) | any (`elem` tags) $ optExcludeCase opts = return Nothing -runBenchmarkCase opts program entry pad_to tr@(TestRun _ input_spec (Succeeds expected_spec) _ dataset_desc) = do +runBenchmarkCase opts futhark program entry pad_to tr@(TestRun _ input_spec (Succeeds expected_spec) _ dataset_desc) = do prompt <- mkProgressPrompt (optRuns opts) pad_to dataset_desc -- Report the dataset name before running the program, so that if an @@ -273,6 +276,7 @@ res <- benchmarkDataset (runOptions (prompt . Just) opts) + futhark program entry input_spec diff --git a/src/Futhark/CLI/Misc.hs b/src/Futhark/CLI/Misc.hs --- a/src/Futhark/CLI/Misc.hs +++ b/src/Futhark/CLI/Misc.hs @@ -14,6 +14,7 @@ import Futhark.Compiler import Futhark.Test import Futhark.Util.Options +import System.Environment (getExecutablePath) import System.Exit import System.FilePath import System.IO @@ -47,9 +48,11 @@ let exact = filter ((dataset ==) . runDescription) runs infixes = filter ((dataset `isInfixOf`) . runDescription) runs + futhark <- FutharkExe <$> getExecutablePath + case nubBy ((==) `on` runDescription) $ if null exact then infixes else exact of - [x] -> BS.putStr =<< getValuesBS dir (runInput x) + [x] -> BS.putStr =<< getValuesBS futhark dir (runInput x) [] -> do hPutStr stderr $ "No dataset '" ++ dataset ++ "'.\n" hPutStr stderr "Available datasets:\n" diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -198,10 +198,10 @@ context "Generating reference outputs" $ -- We probably get the concurrency at the test program level, -- so force just one data set at a time here. - ensureReferenceOutput (Just 1) futhark "c" program ios + ensureReferenceOutput (Just 1) (FutharkExe futhark) "c" program ios unless (mode == Interpreted) $ context ("Compiling with --backend=" <> T.pack backend) $ do - compileTestProgram extra_options futhark backend program warnings + compileTestProgram extra_options (FutharkExe futhark) backend program warnings mapM_ (testMetrics progs program) structures unless (mode == Compile) $ do (tuning_opts, _) <- @@ -212,13 +212,13 @@ tuning_opts ++ configExtraOptions progs } context "Running compiled program" $ - accErrors_ $ map (runCompiledEntry program progs') ios + accErrors_ $ map (runCompiledEntry (FutharkExe futhark) program progs') ios unless (mode == Compile || mode == Compiled) $ context "Interpreting" $ - accErrors_ $ map (runInterpretedEntry futhark program) ios + accErrors_ $ map (runInterpretedEntry (FutharkExe futhark) program) ios -runInterpretedEntry :: String -> FilePath -> InputOutputs -> TestM () -runInterpretedEntry futhark program (InputOutputs entry run_cases) = +runInterpretedEntry :: FutharkExe -> FilePath -> InputOutputs -> TestM () +runInterpretedEntry (FutharkExe futhark) program (InputOutputs entry run_cases) = let dir = takeDirectory program runInterpretedCase run@(TestRun _ inputValues _ index _) = unless ("compiled" `elem` runTags run) $ @@ -228,8 +228,8 @@ <> T.pack (runDescription run) ) $ do - input <- T.unlines . map prettyText <$> getValues dir inputValues - expectedResult' <- getExpectedResult program entry run + input <- T.unlines . map prettyText <$> getValues (FutharkExe futhark) dir inputValues + expectedResult' <- getExpectedResult (FutharkExe futhark) program entry run (code, output, err) <- io $ readProcessWithExitCode futhark ["run", "-e", T.unpack entry, program] $ @@ -241,8 +241,8 @@ =<< runResult program code output err in accErrors_ $ map runInterpretedCase run_cases -runCompiledEntry :: FilePath -> ProgConfig -> InputOutputs -> TestM () -runCompiledEntry program progs (InputOutputs entry run_cases) = +runCompiledEntry :: FutharkExe -> FilePath -> ProgConfig -> InputOutputs -> TestM () +runCompiledEntry futhark program progs (InputOutputs entry run_cases) = -- Explicitly prefixing the current directory is necessary for -- readProcessWithExitCode to find the binary when binOutputf has -- no path component. @@ -260,9 +260,9 @@ <> T.pack (runDescription run) ) $ do - expected <- getExpectedResult program entry run + expected <- getExpectedResult futhark program entry run (progCode, output, progerr) <- - runProgram runner extra_options program entry inputValues + runProgram futhark runner extra_options program entry inputValues compareResult entry index program expected =<< runResult program progCode output progerr in context ("Running " <> T.pack (unwords $ binpath : entry_options ++ extra_options)) $ @@ -289,7 +289,7 @@ runResult _ (ExitFailure code) _ stderr_s = return $ ErrorResult code stderr_s -compileTestProgram :: [String] -> FilePath -> String -> FilePath -> [WarningTest] -> TestM () +compileTestProgram :: [String] -> FutharkExe -> String -> FilePath -> [WarningTest] -> TestM () compileTestProgram extra_options futhark backend program warnings = do (_, futerr) <- compileProgram extra_options futhark backend program testWarnings warnings futerr 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 @@ -659,13 +659,14 @@ m <- get case M.lookup s m of Nothing -> - -- Cheating with the type here; works for the infos we - -- currently use, but should be made more size-aware in - -- the future. + -- XXX: Cheating with the type here; works for the infos we + -- currently use because we zero-initialise and assume a + -- little-endian platform, but should be made more + -- size-aware in the future. modify $ M.insert s' - [C.citems|size_t $id:v; + [C.citems|size_t $id:v = 0; clGetDeviceInfo(ctx->device, $id:s', sizeof($id:v), &$id:v, NULL);|] diff --git a/src/Futhark/IR/Prop/Aliases.hs b/src/Futhark/IR/Prop/Aliases.hs --- a/src/Futhark/IR/Prop/Aliases.hs +++ b/src/Futhark/IR/Prop/Aliases.hs @@ -15,6 +15,7 @@ ( subExpAliases, expAliases, patternAliases, + lookupAliases, Aliased (..), AliasesOf (..), @@ -31,7 +32,8 @@ import Control.Arrow (first) import qualified Data.Kind -import Futhark.IR.Prop (IsOp) +import qualified Data.Map as M +import Futhark.IR.Prop (IsOp, NameInfo (..), Scope) import Futhark.IR.Prop.Names import Futhark.IR.Prop.Patterns import Futhark.IR.Prop.Types @@ -168,6 +170,13 @@ instance AliasesOf dec => AliasesOf (PatElemT dec) where aliasesOf = aliasesOf . patElemDec + +-- | Also includes the name itself. +lookupAliases :: AliasesOf (LetDec lore) => VName -> Scope lore -> Names +lookupAliases v scope = + case M.lookup v scope of + Just (LetName dec) -> oneName v <> aliasesOf dec + _ -> oneName v -- | The class of operations that can produce aliasing and consumption -- information. diff --git a/src/Futhark/IR/Syntax/Core.hs b/src/Futhark/IR/Syntax/Core.hs --- a/src/Futhark/IR/Syntax/Core.hs +++ b/src/Futhark/IR/Syntax/Core.hs @@ -58,6 +58,9 @@ import Control.Category import Control.Monad.State +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable import qualified Data.Map.Strict as M import Data.Maybe import Data.String @@ -232,6 +235,17 @@ | Array PrimType shape u | Mem Space deriving (Show, Eq, Ord, Generic) + +instance Bitraversable TypeBase where + bitraverse f g (Array t shape u) = Array t <$> f shape <*> g u + bitraverse _ _ (Prim pt) = pure $ Prim pt + bitraverse _ _ (Mem s) = pure $ Mem s + +instance Bifunctor TypeBase where + bimap = bimapDefault + +instance Bifoldable TypeBase where + bifoldMap = bifoldMapDefault instance (SexpIso shape, SexpIso u) => SexpIso (TypeBase shape u) where sexpIso = diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -12,6 +12,7 @@ module Futhark.Internalise (internaliseProg) where import Control.Monad.Reader +import Control.Monad.State import Data.Bitraversable import Data.List (find, intercalate, intersperse, nub, transpose) import qualified Data.List.NonEmpty as NE @@ -171,18 +172,61 @@ <*> mapM allDimsFreshInPat pats <*> pure loc +data EntryTrust + = -- | This parameter or return value is an opaque type. When a + -- parameter, this implies that it must have been returned by a + -- previous call to Futhark, and hence we can preserve (constant) + -- size constraints. + EntryTrusted + | -- | The type is directly exposed. Any size constraint cannot be + -- trusted. + EntryUntrusted + +entryTrust :: EntryType -> EntryTrust +entryTrust t + | E.Scalar (E.Prim E.Unsigned {}) <- E.entryType t = + EntryUntrusted + | E.Array _ _ (E.Prim E.Unsigned {}) _ <- E.entryType t = + EntryUntrusted + | E.Scalar E.Prim {} <- E.entryType t = + EntryUntrusted + | E.Array _ _ E.Prim {} _ <- E.entryType t = + EntryUntrusted + | otherwise = + EntryTrusted + +fixEntryParamSizes :: MonadFreshNames m => E.Pattern -> EntryTrust -> m E.Pattern +fixEntryParamSizes p EntryTrusted = pure p +fixEntryParamSizes p EntryUntrusted = allDimsFreshInPat p + +-- When we are returning a value from the entry point, we fully +-- existentialise the return type. This is because it might otherwise +-- refer to sizes that are not in scope, because the generated entry +-- point function does not keep the size parameters of the original +-- entry point. +fullyExistential :: + [[I.TypeBase ExtShape u]] -> + [[I.TypeBase ExtShape u]] +fullyExistential tss = + evalState (mapM (mapM (bitraverse (traverse onDim) pure)) tss) 0 + where + onDim _ = do + i <- get + modify (+ 1) + pure $ Ext i + generateEntryPoint :: E.EntryPoint -> E.ValBind -> InternaliseM () generateEntryPoint (E.EntryPoint e_paramts e_rettype) vb = localConstsScope $ do let (E.ValBind _ ofname _ (Info (rettype, _)) _ params _ _ attrs loc) = vb -- We replace all shape annotations, so there should be no constant -- parameters here. - params_fresh <- mapM allDimsFreshInPat params + params_fresh <- zipWithM fixEntryParamSizes params $ map entryTrust e_paramts let tparams = map (`E.TypeParamDim` mempty) $ S.toList $ mconcat $ map E.patternDimNames params_fresh bindingParams tparams params_fresh $ \shapeparams params' -> do - entry_rettype <- internaliseEntryReturnType $ anySizes rettype + entry_rettype <- fullyExistential <$> internaliseEntryReturnType rettype let entry' = entryPoint (zip e_paramts params') (e_rettype, entry_rettype) args = map (I.Var . I.paramName) $ concat params' @@ -1959,12 +2003,20 @@ case rettype_fun $ zip args' argts' of Nothing -> error $ - "Cannot apply " ++ pretty fname ++ " to arguments\n " - ++ pretty args' - ++ "\nof types\n " - ++ pretty argts' - ++ "\nFunction has parameters\n " - ++ pretty fun_params + concat + [ "Cannot apply ", + pretty fname, + " to ", + show (length args'), + " arguments\n ", + pretty args', + "\nof types\n ", + pretty argts', + "\nFunction has ", + show (length fun_params), + " parameters\n ", + pretty fun_params + ] Just ts -> do safety <- askSafety attrs <- asks envAttrs 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Trustworthy #-} @@ -39,6 +40,7 @@ import qualified Data.Sequence as Seq import qualified Data.Set as S import Futhark.MonadFreshNames +import Futhark.Util.Pretty import Language.Futhark import Language.Futhark.Semantic (TypeBinding (..)) import Language.Futhark.Traversals @@ -140,19 +142,40 @@ -- Given instantiated type of function, produce size arguments. type InferSizeArgs = StructType -> [Exp] --- The kind of type relative to which we monomorphise. What is +data MonoSize + = -- | The integer encodes an equivalence class, so we can keep + -- track of sizes that are statically identical. + MonoKnown Int + | MonoAnon + deriving (Eq, Ord, Show) + +instance Pretty MonoSize where + ppr (MonoKnown i) = text "?" <> ppr i + ppr MonoAnon = text "?" + +instance Pretty (ShapeDecl MonoSize) where + ppr (ShapeDecl ds) = mconcat (map (brackets . ppr) ds) + +-- The kind of type relative to which we monomorphise. What is most -- important to us is not the specific dimensions, but merely whether --- they are known or anonymous/local (the latter False). -type MonoType = TypeBase Bool () +-- they are known or anonymous/local. +type MonoType = TypeBase MonoSize () monoType :: TypeBase (DimDecl VName) als -> MonoType -monoType = runIdentity . traverseDims onDim . toStruct +monoType = (`evalState` (0, mempty)) . traverseDims onDim . toStruct where onDim bound _ (NamedDim d) -- A locally bound size. - | qualLeaf d `S.member` bound = pure False - onDim _ _ AnyDim = pure False - onDim _ _ _ = pure True + | qualLeaf d `S.member` bound = pure MonoAnon + onDim _ _ AnyDim = pure MonoAnon + onDim _ _ d = do + (i, m) <- get + case M.lookup d m of + Just prev -> + pure $ MonoKnown prev + Nothing -> do + put (i + 1, M.insert d i m) + pure $ MonoKnown i -- Mapping from function name and instance list to a new function name in case -- the function has already been instantiated with those concrete types. @@ -175,9 +198,10 @@ transformFName loc fname t | baseTag (qualLeaf fname) <= maxIntrinsicTag = return $ var fname | otherwise = do - maybe_fname <- lookupLifted (qualLeaf fname) (monoType t) - maybe_funbind <- lookupFun $ qualLeaf fname t' <- removeTypeVariablesInType t + let mono_t = monoType t' + maybe_fname <- lookupLifted (qualLeaf fname) mono_t + maybe_funbind <- lookupFun $ qualLeaf fname case (maybe_fname, maybe_funbind) of -- The function has already been monomorphised. (Just (fname', infer), _) -> @@ -186,9 +210,9 @@ (Nothing, Nothing) -> return $ var fname -- A polymorphic function. (Nothing, Just funbind) -> do - (fname', infer, funbind') <- monomorphiseBinding False funbind (monoType t') + (fname', infer, funbind') <- monomorphiseBinding False funbind mono_t tell $ Seq.singleton (qualLeaf fname, funbind') - addLifted (qualLeaf fname) (monoType t) (fname', infer) + addLifted (qualLeaf fname) mono_t (fname', infer) return $ applySizeArgs fname' t' $ infer t' where var fname' = Var fname' (Info (fromStruct t)) loc @@ -658,7 +682,7 @@ where onDims d1 d2 = do case (d1, d2) of - (NamedDim v, True) -> modify $ S.insert $ qualLeaf v + (NamedDim v, MonoKnown _) -> modify $ S.insert $ qualLeaf v _ -> return () return d1 @@ -768,7 +792,7 @@ m (M.Map VName StructType, [TypeParam]) typeSubstsM loc orig_t1 orig_t2 = let m = sub orig_t1 orig_t2 - in runWriterT $ execStateT m mempty + in runWriterT $ fst <$> execStateT m (mempty, mempty) where sub t1@Array {} t2@Array {} | Just t1' <- peelArray (arrayRank t1) t1, @@ -793,16 +817,22 @@ sub t1 t2 = error $ unlines ["typeSubstsM: mismatched types:", pretty t1, pretty t2] addSubst (TypeName _ v) t = do - exists <- gets $ M.member v - unless exists $ do + (ts, sizes) <- get + unless (v `M.member` ts) $ do t' <- bitraverse onDim pure t - modify $ M.insert v t' + put (M.insert v t' ts, sizes) - onDim True = do - d <- lift $ lift $ newVName "d" - tell [TypeParamDim d loc] - return $ NamedDim $ qualName d - onDim False = return AnyDim + onDim (MonoKnown i) = do + (ts, sizes) <- get + case M.lookup i sizes of + Nothing -> do + d <- lift $ lift $ newVName "d" + tell [TypeParamDim d loc] + put (ts, M.insert i d sizes) + return $ NamedDim $ qualName d + Just d -> + return $ NamedDim $ qualName d + onDim MonoAnon = return AnyDim -- Perform a given substitution on the types in a pattern. substPattern :: Bool -> (PatternType -> PatternType) -> Pattern -> Pattern 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 @@ -13,10 +13,9 @@ -- @ -- let r = -- loop (r1 = r0) = for i < n do --- let a = r1[i] in --- let r1[i] = a * i in --- r1 --- in +-- let a = r1[i] +-- let r1[i] = a * i +-- in r1 -- ... -- let x = y with [k] <- r in -- ... @@ -27,11 +26,10 @@ -- @ -- let x0 = y with [k] <- r0 -- loop (x = x0) = for i < n do --- let a = a[k,i] in --- let x[k,i] = a * i in --- x --- in --- let r = x[y] in +-- let a = a[k,i] +-- let x[k,i] = a * i +-- in x +-- let r = x[k] in -- ... -- @ -- 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 @@ -13,7 +13,6 @@ import Control.Monad.Writer import Data.Either import Data.List (find, unzip4) -import qualified Data.Map as M import Data.Maybe (mapMaybe) import Futhark.Analysis.PrimExp.Convert import Futhark.Construct @@ -205,7 +204,7 @@ forM_ (zip val $ bodyAliases body) $ \((p, _), als) -> guard $ not $ paramName p `nameIn` als - mk_in_place_map <- summariseLoop updates usedInBody resmap val + mk_in_place_map <- summariseLoop scope updates usedInBody resmap val Just $ do in_place_map <- mk_in_place_map @@ -217,10 +216,8 @@ let body' = mkBody (newbnds <> res_bnds) body_res return (prebnds, postbnds, ctxpat, valpat, ctx, val', body') where - usedInBody = mconcat $ map expandAliases $ namesToList $ freeIn body <> freeIn form - expandAliases v = case M.lookup v scope of - Just (LetName dec) -> oneName v <> aliasesOf dec - _ -> oneName v + usedInBody = + mconcat $ map (`lookupAliases` scope) $ namesToList $ freeIn body <> freeIn form resmap = zip (bodyResult body) $ patternValueIdents pat mkMerges :: @@ -277,18 +274,22 @@ Left (inPatternAs summary) summariseLoop :: - MonadFreshNames m => + ( Aliased lore, + MonadFreshNames m + ) => + Scope lore -> [DesiredUpdate (als, Type)] -> Names -> [(SubExp, Ident)] -> [(Param DeclType, SubExp)] -> Maybe (m [LoopResultSummary (als, Type)]) -summariseLoop updates usedInBody resmap merge = +summariseLoop scope updates usedInBody resmap merge = sequence <$> zipWithM summariseLoopResult resmap merge where summariseLoopResult (se, v) (fparam, mergeinit) | Just update <- find (updateHasValue $ identName v) updates = - if updateSource update `nameIn` usedInBody + -- Safety condition (7) + if usedInBody `namesIntersect` lookupAliases (updateSource update) scope then Nothing else if hasLoopInvariantShape fparam diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -348,7 +348,9 @@ -- Expand the loop merge parameters to be arrays. tileDim t = arrayOf t (tilingTileShape tiling) $ uniqueness t - tiledBody' privstms = inScopeOf host_stms $ do + merge_scope = M.insert i (IndexName it) $ scopeOfFParams mergeparams + + tiledBody' privstms = localScope (scopeOf host_stms <> merge_scope) $ do addStms invariant_prestms let live_set = @@ -357,6 +359,7 @@ freeIn recomputed_variant_prestms <> used_in_body <> freeIn poststms + <> freeIn poststms_res prelude_arrs <- inScopeOf precomputed_variant_prestms $ @@ -400,7 +403,7 @@ letTupExp "tiled_inside_loop" $ DoLoop [] merge' (ForLoop i it bound []) loopbody' - postludeGeneric tiling inloop_privstms pat accs' poststms poststms_res res_ts + postludeGeneric tiling (privstms <> inloop_privstms) pat accs' poststms poststms_res res_ts return (host_stms, tiling, tiledBody') where diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -11,6 +11,7 @@ testSpecsFromPaths, testSpecsFromPathsOrDie, valuesFromByteString, + FutharkExe (..), getValues, getValuesBS, compareValues, @@ -592,14 +593,21 @@ valuesFromByteString srcname = maybe (Left $ "Cannot parse values from '" ++ srcname ++ "'") Right . readValues +-- | The @futhark@ executable we are using. This is merely a wrapper +-- around the underlying file path, because we will be using a lot of +-- different file paths here, and it is easy to mix them up. +newtype FutharkExe = FutharkExe FilePath + deriving (Eq, Ord, Show) + -- | Get the actual core Futhark values corresponding to a 'Values' --- specification. The 'FilePath' is the directory which file paths --- are read relative to. -getValues :: (MonadFail m, MonadIO m) => FilePath -> Values -> m [Value] -getValues _ (Values vs) = +-- specification. The first 'FilePath' is the path of the @futhark@ +-- executable, and the second is the directory which file paths are +-- read relative to. +getValues :: (MonadFail m, MonadIO m) => FutharkExe -> FilePath -> Values -> m [Value] +getValues _ _ (Values vs) = return vs -getValues dir v = do - s <- getValuesBS dir v +getValues futhark dir v = do + s <- getValuesBS futhark dir v case valuesFromByteString file s of Left e -> fail e Right vs -> return vs @@ -612,10 +620,10 @@ -- | Extract a pretty representation of some 'Values'. In the IO -- monad because this might involve reading from a file. There is no -- guarantee that the resulting byte string yields a readable value. -getValuesBS :: MonadIO m => FilePath -> Values -> m BS.ByteString -getValuesBS _ (Values vs) = +getValuesBS :: MonadIO m => FutharkExe -> FilePath -> Values -> m BS.ByteString +getValuesBS _ _ (Values vs) = return $ BS.fromStrict $ T.encodeUtf8 $ T.unlines $ map prettyText vs -getValuesBS dir (InFile file) = +getValuesBS _ dir (InFile file) = case takeExtension file of ".gz" -> liftIO $ do s <- E.try readAndDecompress @@ -628,8 +636,8 @@ readAndDecompress = do s <- BS.readFile file' E.evaluate $ decompress s -getValuesBS dir (GenValues gens) = - mconcat <$> mapM (getGenBS dir) gens +getValuesBS futhark dir (GenValues gens) = + mconcat <$> mapM (getGenBS futhark dir) gens -- | There is a risk of race conditions when multiple programs have -- identical 'GenValues'. In such cases, multiple threads in 'futhark @@ -641,8 +649,8 @@ -- approach here seems robust enough for now, but certainly it could -- be made even better. The race condition that remains should mostly -- result in duplicate work, not crashes or data corruption. -getGenBS :: MonadIO m => FilePath -> GenValue -> m BS.ByteString -getGenBS dir gen = do +getGenBS :: MonadIO m => FutharkExe -> FilePath -> GenValue -> m BS.ByteString +getGenBS futhark dir gen = do liftIO $ createDirectoryIfMissing True $ dir "data" exists_and_proper_size <- liftIO $ @@ -653,18 +661,18 @@ else E.throw ex unless exists_and_proper_size $ liftIO $ do - s <- genValues [gen] + s <- genValues futhark [gen] withTempFile (dir "data") (genFileName gen) $ \tmpfile h -> do hClose h -- We will be writing and reading this ourselves. SBS.writeFile tmpfile s renameFile tmpfile $ dir file - getValuesBS dir $ InFile file + getValuesBS futhark dir $ InFile file where file = "data" genFileName gen -genValues :: [GenValue] -> IO SBS.ByteString -genValues gens = do - (code, stdout, stderr) <- readProcessWithExitCode "futhark" ("dataset" : args) mempty +genValues :: FutharkExe -> [GenValue] -> IO SBS.ByteString +genValues (FutharkExe futhark) gens = do + (code, stdout, stderr) <- readProcessWithExitCode futhark ("dataset" : args) mempty case code of ExitSuccess -> return stdout @@ -715,16 +723,18 @@ -- | Get the values corresponding to an expected result, if any. getExpectedResult :: (MonadFail m, MonadIO m) => + FutharkExe -> FilePath -> T.Text -> TestRun -> m (ExpectedResult [Value]) -getExpectedResult prog entry tr = +getExpectedResult futhark prog entry tr = case runExpectedResult tr of (Succeeds (Just (SuccessValues vals))) -> - Succeeds . Just <$> getValues (takeDirectory prog) vals + Succeeds . Just <$> getValues futhark (takeDirectory prog) vals Succeeds (Just SuccessGenerateValues) -> getExpectedResult + futhark prog entry tr @@ -751,11 +761,11 @@ compileProgram :: (MonadIO m, MonadError [T.Text] m) => [String] -> - FilePath -> + FutharkExe -> String -> FilePath -> m (SBS.ByteString, SBS.ByteString) -compileProgram extra_options futhark backend program = do +compileProgram extra_options (FutharkExe futhark) backend program = do (futcode, stdout, stderr) <- liftIO $ readProcessWithExitCode futhark (backend : options) "" case futcode of ExitFailure 127 -> throwError [progNotFound $ T.pack futhark] @@ -767,7 +777,7 @@ options = [program, "-o", binOutputf] ++ extra_options progNotFound s = s <> ": command not found" --- | @runProgram runner extra_options prog entry input@ runs the +-- | @runProgram futhark runner extra_options prog entry input@ runs the -- Futhark program @prog@ (which must have the @.fut@ suffix), -- executing the @entry@ entry point and providing @input@ on stdin. -- The program must have been compiled in advance with @@ -777,13 +787,14 @@ -- program. runProgram :: MonadIO m => - String -> + FutharkExe -> + FilePath -> [String] -> String -> T.Text -> Values -> m (ExitCode, SBS.ByteString, SBS.ByteString) -runProgram runner extra_options prog entry input = do +runProgram futhark runner extra_options prog entry input = do let progbin = binaryName prog dir = takeDirectory prog binpath = "." progbin @@ -793,7 +804,7 @@ | null runner = (binpath, entry_options ++ extra_options) | otherwise = (runner, binpath : entry_options ++ extra_options) - input' <- getValuesBS dir input + input' <- getValuesBS futhark dir input liftIO $ readProcessWithExitCode to_run to_run_args $ BS.toStrict input' -- | Ensure that any reference output files exist, or create them (by @@ -802,7 +813,7 @@ ensureReferenceOutput :: (MonadIO m, MonadError [T.Text] m) => Maybe Int -> - FilePath -> + FutharkExe -> String -> FilePath -> [InputOutputs] -> @@ -815,7 +826,7 @@ res <- liftIO $ flip (pmapIO concurrency) missing $ \(entry, tr) -> do - (code, stdout, stderr) <- runProgram "" ["-b"] prog entry $ runInput tr + (code, stdout, stderr) <- runProgram futhark "" ["-b"] prog entry $ runInput tr case code of ExitFailure e -> return $ diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs --- a/src/Futhark/TypeCheck.hs +++ b/src/Futhark/TypeCheck.hs @@ -60,7 +60,7 @@ import qualified Data.Set as S import Futhark.Analysis.PrimExp import Futhark.Construct (instantiateShapes) -import Futhark.IR.Aliases +import Futhark.IR.Aliases hiding (lookupAliases) import Futhark.Util import Futhark.Util.Pretty (Pretty, align, indent, ppr, prettyDoc, text, (<+>)) @@ -913,7 +913,9 @@ checkExp (BasicOp op) = checkBasicOp op checkExp (If e1 e2 e3 info) = do require [Prim Bool] e1 - _ <- checkBody e2 `alternative` checkBody e3 + _ <- + context "in true branch" (checkBody e2) + `alternative` context "in false branch" (checkBody e3) context "in true branch" $ matchBranchType (ifReturns info) e2 context "in false branch" $ matchBranchType (ifReturns info) e3 checkExp (Apply fname args rettype_annot _) = do diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -276,31 +276,36 @@ trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace -fork :: (a -> IO b) -> a -> IO (MVar b) -fork f x = do - cell <- newEmptyMVar - void $ - forkIO $ do - result <- f x - putMVar cell result - return cell - -- | Run various 'IO' actions concurrently, possibly with a bound on --- the number of threads. +-- the number of threads. The list must be finite. The ordering of +-- the result list is not deterministic - add your own sorting if +-- needed. If any of the actions throw an exception, then that +-- exception is propagated to this function. pmapIO :: Maybe Int -> (a -> IO b) -> [a] -> IO [b] -pmapIO concurrency f elems = go elems [] +pmapIO concurrency f elems = do + tasks <- newMVar elems + results <- newEmptyMVar + num_threads <- maybe getNumCapabilities pure concurrency + replicateM_ num_threads $ forkIO $ worker tasks results + replicateM (length elems) $ getResult results where - go [] res = return res - go xs res = do - numThreads <- maybe getNumCapabilities pure concurrency - let (e, es) = splitAt numThreads xs - mvars <- mapM (fork f') e - result <- mapM takeMVar mvars - case sequence result of - Left err -> throw (err :: SomeException) - Right result' -> go es (result' ++ res) + worker tasks results = do + task <- modifyMVar tasks getTask + case task of + Nothing -> pure () + Just x -> do + y <- (Right <$> f x) `catch` (pure . Left) + putMVar results y + worker tasks results - f' x = (Right <$> f x) `catch` (pure . Left) + getTask [] = pure ([], Nothing) + getTask (task : tasks) = pure (tasks, Just task) + + getResult results = do + res <- takeMVar results + case res of + Left err -> throw (err :: SomeException) + Right v -> pure v -- Z-encoding from https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/SymbolNames -- diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -248,7 +248,14 @@ -- Stores the full shape. instance Eq Value where - ValuePrim x == ValuePrim y = x == y + ValuePrim (SignedValue x) == ValuePrim (SignedValue y) = + P.doCmpEq (P.IntValue x) (P.IntValue y) + ValuePrim (UnsignedValue x) == ValuePrim (UnsignedValue y) = + P.doCmpEq (P.IntValue x) (P.IntValue y) + ValuePrim (FloatValue x) == ValuePrim (FloatValue y) = + P.doCmpEq (P.FloatValue x) (P.FloatValue y) + ValuePrim (BoolValue x) == ValuePrim (BoolValue y) = + P.doCmpEq (P.BoolValue x) (P.BoolValue y) ValueArray _ x == ValueArray _ y = x == y ValueRecord x == ValueRecord y = x == y ValueSum _ n1 vs1 == ValueSum _ n2 vs2 = n1 == n2 && vs1 == vs2 diff --git a/src/Language/Futhark/Prop.hs b/src/Language/Futhark/Prop.hs --- a/src/Language/Futhark/Prop.hs +++ b/src/Language/Futhark/Prop.hs @@ -413,7 +413,18 @@ TypeBase dim as combineTypeShapes (Scalar (Record ts1)) (Scalar (Record ts2)) | M.keys ts1 == M.keys ts2 = - Scalar $ Record $ M.map (uncurry combineTypeShapes) (M.intersectionWith (,) ts1 ts2) + Scalar $ + Record $ + M.map + (uncurry combineTypeShapes) + (M.intersectionWith (,) ts1 ts2) +combineTypeShapes (Scalar (Sum cs1)) (Scalar (Sum cs2)) + | M.keys cs1 == M.keys cs2 = + Scalar $ + Sum $ + M.map + (uncurry $ zipWith combineTypeShapes) + (M.intersectionWith (,) cs1 cs2) combineTypeShapes (Scalar (Arrow als1 p1 a1 b1)) (Scalar (Arrow als2 _p2 a2 b2)) = Scalar $ Arrow (als1 <> als2) p1 (combineTypeShapes a1 a2) (combineTypeShapes b1 b2) combineTypeShapes (Scalar (TypeVar als1 u1 v targs1)) (Scalar (TypeVar als2 _ _ targs2)) =