futhark 0.17.2 → 0.17.3

raw patch · 21 files changed

+296/−141 lines, 21 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• docs/index.rst +2/−2
• futhark.cabal +1/−1
• src/Futhark/Actions.hs +2/−2
• src/Futhark/Bench.hs +6/−5
• src/Futhark/CLI/Autotune.hs +6/−3
• src/Futhark/CLI/Bench.hs +11/−7
• src/Futhark/CLI/Misc.hs +4/−1
• src/Futhark/CLI/Test.hs +13/−13
• src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +5/−4
• src/Futhark/IR/Prop/Aliases.hs +10/−1
• src/Futhark/IR/Syntax/Core.hs +14/−0
• src/Futhark/Internalise.hs +60/−8
• src/Futhark/Internalise/Monomorphise.hs +51/−21
• src/Futhark/Optimise/InPlaceLowering.hs +7/−9
• src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +10/−9
• src/Futhark/Optimise/TileLoops.hs +5/−2
• src/Futhark/Test.hs +39/−28
• src/Futhark/TypeCheck.hs +4/−2
• src/Futhark/Util.hs +26/−21
• src/Language/Futhark/Interpreter.hs +8/−1
• src/Language/Futhark/Prop.hs +12/−1

@@ -15,8 +15,8 @@ better served by reading `Parallel Programming in Futhark <https://futhark-book.readthedocs.io>`_ first. -Documentation for the included basis library is also `available online-<https://futhark-lang.org/docs/>`_.+Documentation for the built-in prelude is also `available online+<https://futhark-lang.org/docs/prelude/>`_.  The particularly interested reader may also want to peruse the `publications <https://futhark-lang.org/docs.html#publications>`_, or

@@ -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

@@ -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

@@ -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 $

@@ -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) $

@@ -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

@@ -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"

@@ -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

@@ -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);|]

@@ -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.

@@ -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 =

@@ -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

@@ -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

@@ -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 --   ... -- @ --

@@ -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

@@ -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

@@ -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 $

@@ -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

@@ -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 --

@@ -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

@@ -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)) =