diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,38 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## [0.25.34] + +### Added + +* Support for CUDA 13. + +### Fixed + +* Declaration of zero-length arrays in GPU kernels. + +* Handling of size closures of type abbreviations in interpreter (#2316). + +* `futhark literate` deleted `CACHEDIR.TAG` files. + +* `futhark literate` now prints records and tuples properly. + +* Some optimisations would throw away source location information, resulting in + worse profiling data. + +* Tighter source locations for `let x[i] = ...` expressions. + +* Oversight in size expressions in let-bindings. (#2322) + +* `futhark pkg` is now more robust against errors in package data. + +* Incorrect uniqueness inference for functions returning abstract types. (#2324) + +* Duplication of entry points in some cases. (#2326) + +* A race condition in the creation of `CACHEDIR.TAG` files that could cause + `futhark bench` and `futhark test` to crash. + ## [0.25.33] ### Added diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -1804,7 +1804,7 @@ ``scratch`` ........... -Like ``blank``, but the resulting values (if arrays) will comprise initialised +Like ``blank``, but the resulting values (if arrays) will comprise uninitialised memory. Reading from such arrays is potentially dangerous, as the elements are completely undefined until they are updated with a ``scatter`` or similar. diff --git a/docs/man/futhark-literate.rst b/docs/man/futhark-literate.rst --- a/docs/man/futhark-literate.rst +++ b/docs/man/futhark-literate.rst @@ -241,16 +241,17 @@ Only an extremely limited subset of Futhark is supported: .. productionlist:: - script_exp: `fun` `script_exp`* - : | "(" `script_exp` ")" - : | "(" `script_exp` ( "," `script_exp` )+ ")" - : | "[" `script_exp` ( "," `script_exp` )+ "]" - : | "empty" "(" ("[" `decimal` "]" )+ `script_type` ")" - : | "{" "}" - : | "{" (`id` = `script_exp`) ("," `id` = `script_exp`)* "}" - : | "let" `script_pat` "=" `script_exp` "in" `script_exp` - : | `literal` - script_pat: `id` | "(" `id` ("," `id`) ")" + script_exp: `script_fun` `script_exp`* + : | "let" `script_pat` "=" `script_exp` "in" `script_exp` + : | `script_atom` ( "." `fieldid` )* + script_atom: `script_fun` + : | "(" `script_exp` ")" + : | "(" `script_exp` ( "," `script_exp` )+ ")" + : | "[" `script_exp` ( "," `script_exp` )+ "]" + : | "empty" "(" ("[" `decimal` "]" )+ `script_type` ")" + : | "{" "}" + : | "{" (`id` = `script_exp`) ("," `id` = `script_exp`)* "}" + script_pat: `id` | "(" `id` ("," `id`)* ")" script_fun: `id` | "$" `id` script_type: `int_type` | `float_type` | "bool" diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark -version: 0.25.33 +version: 0.25.34 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to @@ -540,6 +540,7 @@ Language.Futhark.SemanticTests Language.Futhark.SyntaxTests Language.Futhark.TypeChecker.TypesTests + Language.Futhark.TypeChecker.ConsumptionTests Language.Futhark.TypeCheckerTests build-depends: QuickCheck >=2.8 diff --git a/rts/c/backends/cuda.h b/rts/c/backends/cuda.h --- a/rts/c/backends/cuda.h +++ b/rts/c/backends/cuda.h @@ -344,7 +344,8 @@ { 9, 0, "compute_90" }, { 10, 0, "compute_100" }, { 10, 1, "compute_101" }, - { 12, 0, "compute_120" } + { 12, 0, "compute_120" }, + { 12, 1, "compute_121" } }; int major = device_query(dev, COMPUTE_CAPABILITY_MAJOR); @@ -768,7 +769,12 @@ if (cuda_device_setup(ctx) != 0) { futhark_panic(-1, "No suitable CUDA device found.\n"); } + // cuCtxCreate grew a new parameter in CUDA 13. +#if (CUDART_VERSION >= 13000) + CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, NULL, 0, ctx->dev)); +#else CUDA_SUCCEED_FATAL(cuCtxCreate(&ctx->cu_ctx, 0, ctx->dev)); +#endif free_list_init(&ctx->gpu_free_list); diff --git a/src-testing/Language/Futhark/SyntaxTests.hs b/src-testing/Language/Futhark/SyntaxTests.hs --- a/src-testing/Language/Futhark/SyntaxTests.hs +++ b/src-testing/Language/Futhark/SyntaxTests.hs @@ -200,6 +200,14 @@ fromString = fromStringParse (second (const NoUniqueness) <$> pType) "StructType" +instance IsString ParamType where + fromString = + fromStringParse (resToParam <$> pType) "ParamType" + +instance IsString ResType where + fromString = + fromStringParse pType "ResType" + instance IsString StructRetType where fromString = fromStringParse (second (pure NoUniqueness) <$> pRetType) "StructRetType" @@ -208,4 +216,7 @@ fromString = fromStringParse pRetType "ResRetType" instance IsString UncheckedExp where - fromString = either (error . T.unpack . syntaxErrorMsg) id . parseExp "string literal" . T.pack + fromString = + either (error . T.unpack . syntaxErrorMsg) id + . parseExp "string literal" + . T.pack diff --git a/src-testing/Language/Futhark/TypeChecker/ConsumptionTests.hs b/src-testing/Language/Futhark/TypeChecker/ConsumptionTests.hs new file mode 100644 --- /dev/null +++ b/src-testing/Language/Futhark/TypeChecker/ConsumptionTests.hs @@ -0,0 +1,63 @@ +module Language.Futhark.TypeChecker.ConsumptionTests + ( tests, + ) +where + +import Data.Bifunctor +import Data.Set qualified as S +import Language.Futhark +import Language.Futhark.SyntaxTests () +import Language.Futhark.TypeChecker.Consumption +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "ConsumptionTests" + [ testGroup + "inferReturnUniqueness" + [ testCase "*[]i32" $ + inferReturnUniqueness + [Id "x_1" (Info "[2]i32") mempty] + "[2]i32" + (second (const mempty) ("[2]i32" :: StructType)) + @?= "*[2]i32", + -- + testCase "[]i32" $ + inferReturnUniqueness + [Id "x_1" (Info "[2]i32") mempty] + "[2]i32" + ( second + (const (S.singleton (AliasBound "x_1"))) + ("[2]i32" :: StructType) + ) + @?= "[2]i32", + -- + testCase "([]i32,[]i32)" $ + inferReturnUniqueness + [Id "x_1" (Info "[2]i32") mempty] + "([2]i32, [2]i32)" + ( second + (const (S.singleton (AliasFree "y_2"))) + ("([2]i32,[2]i32)" :: StructType) + ) + @?= "([2]i32, [2]i32)", + -- + testCase "opaque" $ + let t = Scalar (TypeVar Nonunique (qualName "t_2") []) + in inferReturnUniqueness + [Id "n_1" (Info "i64") mempty] + t + (second (const (S.singleton (AliasFree "y_3"))) t) + @?= (t `setUniqueness` Nonunique), + -- + testCase "*opaque" $ + let t = Scalar (TypeVar Nonunique (qualName "t_2") []) + in inferReturnUniqueness + [Id "n_1" (Info "i64") mempty] + t + (second (const mempty) t) + @?= (t `setUniqueness` Unique) + ] + ] diff --git a/src-testing/Language/Futhark/TypeCheckerTests.hs b/src-testing/Language/Futhark/TypeCheckerTests.hs --- a/src-testing/Language/Futhark/TypeCheckerTests.hs +++ b/src-testing/Language/Futhark/TypeCheckerTests.hs @@ -1,5 +1,6 @@ module Language.Futhark.TypeCheckerTests (tests) where +import Language.Futhark.TypeChecker.ConsumptionTests qualified import Language.Futhark.TypeChecker.TypesTests qualified import Test.Tasty @@ -7,5 +8,6 @@ tests = testGroup "Source type checker tests" - [ Language.Futhark.TypeChecker.TypesTests.tests + [ Language.Futhark.TypeChecker.TypesTests.tests, + Language.Futhark.TypeChecker.ConsumptionTests.tests ] diff --git a/src/Futhark/Analysis/SymbolTable.hs b/src/Futhark/Analysis/SymbolTable.hs --- a/src/Futhark/Analysis/SymbolTable.hs +++ b/src/Futhark/Analysis/SymbolTable.hs @@ -45,6 +45,8 @@ insertLParam, insertLoopVar, insertLoopMerge, + insertFreeVar, + insertScope, -- * Misc hideCertified, @@ -76,28 +78,15 @@ simplifyMemory :: Bool } -instance Semigroup (SymbolTable rep) where - table1 <> table2 = - SymbolTable - { loopDepth = max (loopDepth table1) (loopDepth table2), - bindings = bindings table1 <> bindings table2, - availableAtClosestLoop = - availableAtClosestLoop table1 - <> availableAtClosestLoop table2, - simplifyMemory = simplifyMemory table1 || simplifyMemory table2 - } - -instance Monoid (SymbolTable rep) where - mempty = empty - empty :: SymbolTable rep empty = SymbolTable 0 M.empty mempty False +-- | Construct a symbol table from a scope. All names in the scope are +-- considered as free variables. Equivalent to 'insertScope' on 'empty'. fromScope :: (ASTRep rep) => Scope rep -> SymbolTable rep -fromScope = M.foldlWithKey' insertFreeVar' empty - where - insertFreeVar' m k dec = insertFreeVar k dec m +fromScope scope = insertScope scope empty +-- | Construct a Scope from a symbol table. toScope :: SymbolTable rep -> Scope rep toScope = M.map entryInfo . bindings @@ -578,6 +567,12 @@ freeVarIndex = \_ _ -> Nothing, freeVarAliases = mempty } + +-- | Insert types from a scope as free variables. +insertScope :: (ASTRep rep) => Scope rep -> SymbolTable rep -> SymbolTable rep +insertScope scope st = M.foldlWithKey' insertFreeVar' st scope + where + insertFreeVar' m k dec = insertFreeVar k dec m consume :: VName -> SymbolTable rep -> SymbolTable rep consume consumee vtable = diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -806,15 +806,18 @@ >>= LiftLambdas.transformProg Monomorphise -> do (_, imports, src) <- readProgram' - liftIO $ - p $ - flip evalState src $ - Defunctorise.transformProg imports - >>= ApplyTypeAbbrs.transformProg - >>= FullNormalise.transformProg - >>= ReplaceRecords.transformProg - >>= LiftLambdas.transformProg - >>= Monomorphise.transformProg + let (prog, stats) = + flip evalState src $ + Defunctorise.transformProg imports + >>= ApplyTypeAbbrs.transformProg + >>= FullNormalise.transformProg + >>= ReplaceRecords.transformProg + >>= LiftLambdas.transformProg + >>= Monomorphise.transformProg + liftIO $ do + p prog + putStrLn "" + PP.putDocLn $ PP.pretty stats Defunctionalise -> do (_, imports, src) <- readProgram' liftIO $ @@ -825,7 +828,7 @@ >>= FullNormalise.transformProg >>= ReplaceRecords.transformProg >>= LiftLambdas.transformProg - >>= Monomorphise.transformProg + >>= fmap fst . Monomorphise.transformProg >>= Defunctionalise.transformProg Pipeline {} -> do let (base, ext) = splitExtension file diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs --- a/src/Futhark/CLI/Literate.hs +++ b/src/Futhark/CLI/Literate.hs @@ -1082,7 +1082,8 @@ processScript env script = do (failures, outputs, files) <- unzip3 <$> mapM (processBlock env) script - cleanupImgDir env $ mconcat files + cleanupImgDir env $ + (envImgDir env "CACHEDIR.TAG") `S.insert` mconcat files pure (L.foldl' min Success failures, T.intercalate "\n" outputs) -- | Common command line options that transform 'Options'. diff --git a/src/Futhark/CodeGen/Backends/GenericC/Monad.hs b/src/Futhark/CodeGen/Backends/GenericC/Monad.hs --- a/src/Futhark/CodeGen/Backends/GenericC/Monad.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/Monad.hs @@ -483,8 +483,13 @@ rawMemCType (Space sid) = join $ asks (opsMemoryType . envOperations) <*> pure sid rawMemCType (ScalarSpace [] t) = pure [C.cty|$ty:(primTypeToCType t)[1]|] -rawMemCType (ScalarSpace ds t) = - pure [C.cty|$ty:(primTypeToCType t)[$exp:(cproduct ds')]|] +rawMemCType (ScalarSpace ds t) + | null ds || Constant (IntValue (Int64Value 0)) `elem` ds = + -- The case where a 0 ends up here is pretty obscure, but it can occur for + -- some empty array literals. + pure [C.cty|$ty:(primTypeToCType t)[1]|] + | otherwise = + pure [C.cty|$ty:(primTypeToCType t)[$exp:(cproduct ds')]|] where ds' = map (`C.toExp` noLoc) ds diff --git a/src/Futhark/CodeGen/ImpGen/Multicore.hs b/src/Futhark/CodeGen/ImpGen/Multicore.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore.hs @@ -136,7 +136,7 @@ seq_code <- collect $ localOps inThreadOps $ do nsubtasks <- dPrim "nsubtasks" sOp $ Imp.GetNumTasks $ tvVar nsubtasks - emit =<< compileSegOp pat op nsubtasks + compileSegOp pat op nsubtasks retvals <- getReturnParams pat op let scheduling_info = Imp.SchedulerInfo (untyped iterations) @@ -148,7 +148,7 @@ par_code <- collect $ do nsubtasks <- dPrim "nsubtasks" sOp $ Imp.GetNumTasks $ tvVar nsubtasks - emit =<< compileSegOp pat nested_op nsubtasks + compileSegOp pat nested_op nsubtasks pure $ Just $ Imp.ParallelTask par_code Nothing -> pure Nothing @@ -166,7 +166,7 @@ Pat LetDecMem -> SegOp () MCMem -> TV Int32 -> - ImpM MCMem HostEnv Imp.Multicore Imp.MCCode + ImpM MCMem HostEnv Imp.Multicore () compileSegOp pat (SegHist _ space _ kbody histops) ntasks = compileSegHist pat space histops kbody ntasks compileSegOp pat (SegScan _ space _ kbody scans) ntasks = diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs @@ -22,7 +22,7 @@ [HistOp MCMem] -> KernelBody MCMem -> TV Int32 -> - MulticoreGen Imp.MCCode + MulticoreGen () compileSegHist pat space histops kbody nsubtasks | [_] <- unSegSpace space = nonsegmentedHist pat space histops kbody nsubtasks @@ -53,7 +53,7 @@ [HistOp MCMem] -> KernelBody MCMem -> TV Int32 -> - MulticoreGen Imp.MCCode + MulticoreGen () nonsegmentedHist pat space histops kbody num_histos = do let ns = map snd $ unSegSpace space ns_64 = map pe64 ns @@ -64,12 +64,11 @@ histops' <- renameHistOpLambda histops -- Only do something if there is actually input. - collect $ - sUnless (product ns_64 .==. 0) $ do - sIf - use_subhistogram - (subHistogram pat space histops num_histos kbody) - (atomicHistogram pat space histops' kbody) + sUnless (product ns_64 .==. 0) $ + sIf + use_subhistogram + (subHistogram pat space histops num_histos kbody) + (atomicHistogram pat space histops' kbody) -- | -- Atomic Histogram approach @@ -300,7 +299,7 @@ red_code <- collect $ do nsubtasks <- dPrim "nsubtasks" sOp $ Imp.GetNumTasks $ tvVar nsubtasks - emit <=< compileSegRed' (Pat red_pes) segred_space [segred_op] nsubtasks $ \red_cont -> + compileSegRed' (Pat red_pes) segred_space [segred_op] nsubtasks $ \red_cont -> red_cont $ segBinOpChunks [segred_op] $ flip map hists $ \subhisto -> @@ -329,13 +328,12 @@ SegSpace -> [HistOp MCMem] -> KernelBody MCMem -> - MulticoreGen Imp.MCCode + MulticoreGen () segmentedHist pat space histops kbody = do emit $ Imp.DebugPrint "Segmented segHist" Nothing - collect $ do - body <- compileSegHistBody pat space histops kbody - free_params <- freeParams body - emit $ Imp.Op $ Imp.ParLoop "segmented_hist" body free_params + body <- compileSegHistBody pat space histops kbody + free_params <- freeParams body + emit $ Imp.Op $ Imp.ParLoop "segmented_hist" body free_params compileSegHistBody :: Pat LetDecMem -> diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs @@ -25,8 +25,8 @@ Pat LetDecMem -> SegSpace -> KernelBody MCMem -> - MulticoreGen Imp.MCCode -compileSegMapBody pat space (Body _ kstms kres) = collect $ do + MulticoreGen () +compileSegMapBody pat space (Body _ kstms kres) = do let (is, ns) = unzip $ unSegSpace space ns' = map pe64 ns dPrim_ (segFlat space) int64 @@ -42,8 +42,8 @@ Pat LetDecMem -> SegSpace -> KernelBody MCMem -> - MulticoreGen Imp.MCCode -compileSegMap pat space kbody = collect $ do - body <- compileSegMapBody pat space kbody + MulticoreGen () +compileSegMap pat space kbody = do + body <- collect $ compileSegMapBody pat space kbody free_params <- freeParams body emit $ Imp.Op $ Imp.ParLoop "segmap" body free_params diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs @@ -22,7 +22,7 @@ [SegBinOp MCMem] -> KernelBody MCMem -> TV Int32 -> - MulticoreGen Imp.MCCode + MulticoreGen () compileSegRed pat space reds kbody nsubtasks = compileSegRed' pat space reds nsubtasks $ \red_cont -> compileStms mempty (bodyStms kbody) $ do @@ -41,7 +41,7 @@ [SegBinOp MCMem] -> TV Int32 -> DoSegBody -> - MulticoreGen Imp.MCCode + MulticoreGen () compileSegRed' pat space reds nsubtasks kbody | [_] <- unSegSpace space = nonsegmentedReduction pat space reds nsubtasks kbody @@ -98,8 +98,8 @@ [SegBinOp MCMem] -> TV Int32 -> DoSegBody -> - MulticoreGen Imp.MCCode -nonsegmentedReduction pat space reds nsubtasks kbody = collect $ do + MulticoreGen () +nonsegmentedReduction pat space reds nsubtasks kbody = do thread_res_arrs <- groupResultArrays "reduce_stage_1_tid_res_arr" (tvSize nsubtasks) reds let slugs1 = zipWith SegBinOpSlug reds thread_res_arrs nsubtasks' = tvExp nsubtasks @@ -384,12 +384,11 @@ SegSpace -> [SegBinOp MCMem] -> DoSegBody -> - MulticoreGen Imp.MCCode -segmentedReduction pat space reds kbody = - collect $ do - body <- compileSegRedBody pat space reds kbody - free_params <- freeParams body - emit $ Imp.Op $ Imp.ParLoop "segmented_segred" body free_params + MulticoreGen () +segmentedReduction pat space reds kbody = do + body <- collect $ compileSegRedBody pat space reds kbody + free_params <- freeParams body + emit $ Imp.Op $ Imp.ParLoop "segmented_segred" body free_params -- Currently, this is only used as part of SegHist calculations, never alone. compileSegRedBody :: @@ -397,7 +396,7 @@ SegSpace -> [SegBinOp MCMem] -> DoSegBody -> - MulticoreGen Imp.MCCode + MulticoreGen () compileSegRedBody pat space reds kbody = do let (is, ns) = unzip $ unSegSpace space ns_64 = map pe64 ns @@ -407,40 +406,39 @@ let per_red_pes = segBinOpChunks reds $ patElems pat -- Perform sequential reduce on inner most dimension - collect . inISPC $ - generateChunkLoop "SegRed" Vectorized $ \n_segments -> do - flat_idx <- dPrimVE "flat_idx" $ n_segments * inner_bound - zipWithM_ dPrimV_ is $ unflattenIndex ns_64 flat_idx - sComment "neutral-initialise the accumulators" $ - forM_ (zip per_red_pes reds) $ \(pes, red) -> - forM_ (zip pes (segBinOpNeutral red)) $ \(pe, ne) -> - sLoopNest (segBinOpShape red) $ \vec_is -> - copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ vec_is) ne [] + inISPC $ generateChunkLoop "SegRed" Vectorized $ \n_segments -> do + flat_idx <- dPrimVE "flat_idx" $ n_segments * inner_bound + zipWithM_ dPrimV_ is $ unflattenIndex ns_64 flat_idx + sComment "neutral-initialise the accumulators" $ + forM_ (zip per_red_pes reds) $ \(pes, red) -> + forM_ (zip pes (segBinOpNeutral red)) $ \(pe, ne) -> + sLoopNest (segBinOpShape red) $ \vec_is -> + copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ vec_is) ne [] - sComment "main body" $ do - dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) reds - sFor "i" inner_bound $ \i -> do - zipWithM_ - (<--) - (map mkTV $ init is) - (unflattenIndex (init ns_64) (sExt64 n_segments)) - dPrimV_ (last is) i - kbody $ \red_res' -> do - forM_ (zip3 per_red_pes reds red_res') $ \(pes, red, res') -> - sLoopNest (segBinOpShape red) $ \vec_is -> do - sComment "load accum" $ do - let acc_params = take (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red - forM_ (zip acc_params pes) $ \(p, pe) -> - copyDWIMFix (paramName p) [] (Var $ patElemName pe) (map Imp.le64 (init is) ++ vec_is) + sComment "main body" $ do + dScope Nothing $ scopeOfLParams $ concatMap (lambdaParams . segBinOpLambda) reds + sFor "i" inner_bound $ \i -> do + zipWithM_ + (<--) + (map mkTV $ init is) + (unflattenIndex (init ns_64) (sExt64 n_segments)) + dPrimV_ (last is) i + kbody $ \red_res' -> do + forM_ (zip3 per_red_pes reds red_res') $ \(pes, red, res') -> + sLoopNest (segBinOpShape red) $ \vec_is -> do + sComment "load accum" $ do + let acc_params = take (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red + forM_ (zip acc_params pes) $ \(p, pe) -> + copyDWIMFix (paramName p) [] (Var $ patElemName pe) (map Imp.le64 (init is) ++ vec_is) - sComment "load new val" $ do - let next_params = drop (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red - forM_ (zip next_params res') $ \(p, (res, res_is)) -> - copyDWIMFix (paramName p) [] res (res_is ++ vec_is) + sComment "load new val" $ do + let next_params = drop (length (segBinOpNeutral red)) $ (lambdaParams . segBinOpLambda) red + forM_ (zip next_params res') $ \(p, (res, res_is)) -> + copyDWIMFix (paramName p) [] res (res_is ++ vec_is) - sComment "apply reduction" $ do - let lbody = (lambdaBody . segBinOpLambda) red - compileStms mempty (bodyStms lbody) $ - sComment "write back to res" $ - forM_ (zip pes $ map resSubExp $ bodyResult lbody) $ - \(pe, se') -> copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ vec_is) se' [] + sComment "apply reduction" $ do + let lbody = (lambdaBody . segBinOpLambda) red + compileStms mempty (bodyStms lbody) $ + sComment "write back to res" $ + forM_ (zip pes $ map resSubExp $ bodyResult lbody) $ + \(pe, se') -> copyDWIMFix (patElemName pe) (map Imp.le64 (init is) ++ vec_is) se' [] diff --git a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs @@ -21,7 +21,7 @@ [SegBinOp MCMem] -> KernelBody MCMem -> TV Int32 -> - MulticoreGen Imp.MCCode + MulticoreGen () compileSegScan pat space reds kbody nsubtasks | [_] <- unSegSpace space = nonsegmentedScan pat space reds kbody nsubtasks @@ -55,36 +55,35 @@ [SegBinOp MCMem] -> KernelBody MCMem -> TV Int32 -> - MulticoreGen Imp.MCCode + MulticoreGen () nonsegmentedScan pat space scan_ops kbody nsubtasks = do emit $ Imp.DebugPrint "nonsegmented segScan" Nothing - collect $ do - -- Are we working with nested arrays - let dims = map (shapeDims . segBinOpShape) scan_ops - -- Are we only working on scalars - let scalars = all (all (primType . typeOf . paramDec) . (lambdaParams . segBinOpLambda)) scan_ops && all null dims - -- Do we have nested vector operations - let vectorize = [] `notElem` dims + -- Are we working with nested arrays + let dims = map (shapeDims . segBinOpShape) scan_ops + -- Are we only working on scalars + let scalars = all (all (primType . typeOf . paramDec) . (lambdaParams . segBinOpLambda)) scan_ops && all null dims + -- Do we have nested vector operations + let vectorize = [] `notElem` dims - let param_types = concatMap (map paramType . (lambdaParams . segBinOpLambda)) scan_ops - let no_array_param = all primType param_types + let param_types = concatMap (map paramType . (lambdaParams . segBinOpLambda)) scan_ops + let no_array_param = all primType param_types - let (scanStage1, scanStage3) - | scalars = (scanStage1Scalar, scanStage3Scalar) - | vectorize && no_array_param = (scanStage1Nested, scanStage3Nested) - | otherwise = (scanStage1Fallback, scanStage3Fallback) + let (scanStage1, scanStage3) + | scalars = (scanStage1Scalar, scanStage3Scalar) + | vectorize && no_array_param = (scanStage1Nested, scanStage3Nested) + | otherwise = (scanStage1Fallback, scanStage3Fallback) - emit $ Imp.DebugPrint "Scan stage 1" Nothing - scanStage1 pat space kbody scan_ops + emit $ Imp.DebugPrint "Scan stage 1" Nothing + scanStage1 pat space kbody scan_ops - let nsubtasks' = tvExp nsubtasks - sWhen (nsubtasks' .>. 1) $ do - scan_ops2 <- renameSegBinOp scan_ops - emit $ Imp.DebugPrint "Scan stage 2" Nothing - carries <- scanStage2 pat nsubtasks space scan_ops2 - scan_ops3 <- renameSegBinOp scan_ops - emit $ Imp.DebugPrint "Scan stage 3" Nothing - scanStage3 pat space scan_ops3 carries + let nsubtasks' = tvExp nsubtasks + sWhen (nsubtasks' .>. 1) $ do + scan_ops2 <- renameSegBinOp scan_ops + emit $ Imp.DebugPrint "Scan stage 2" Nothing + carries <- scanStage2 pat nsubtasks space scan_ops2 + scan_ops3 <- renameSegBinOp scan_ops + emit $ Imp.DebugPrint "Scan stage 3" Nothing + scanStage3 pat space scan_ops3 carries -- Different ways to generate code for a scan loop data ScanLoopType @@ -425,13 +424,12 @@ SegSpace -> [SegBinOp MCMem] -> KernelBody MCMem -> - MulticoreGen Imp.MCCode + MulticoreGen () segmentedScan pat space scan_ops kbody = do emit $ Imp.DebugPrint "segmented segScan" Nothing - collect $ do - body <- compileSegScanBody pat space scan_ops kbody - free_params <- freeParams body - emit $ Imp.Op $ Imp.ParLoop "seg_scan" body free_params + body <- compileSegScanBody pat space scan_ops kbody + free_params <- freeParams body + emit $ Imp.Op $ Imp.ParLoop "seg_scan" body free_params compileSegScanBody :: Pat LetDecMem -> diff --git a/src/Futhark/IR/Mem/Simplify.hs b/src/Futhark/IR/Mem/Simplify.hs --- a/src/Futhark/IR/Mem/Simplify.hs +++ b/src/Futhark/IR/Mem/Simplify.hs @@ -98,7 +98,7 @@ Engine.noExtraHoistBlockers { Engine.blockHoistPar = isAlloc, Engine.blockHoistSeq = isResultAlloc, - Engine.isAllocation = isAlloc mempty mempty + Engine.isAllocation = isAlloc ST.empty mempty } -- If an allocation is statically known to be safe, then we can remove diff --git a/src/Futhark/IR/Prop/Scope.hs b/src/Futhark/IR/Prop/Scope.hs --- a/src/Futhark/IR/Prop/Scope.hs +++ b/src/Futhark/IR/Prop/Scope.hs @@ -39,6 +39,7 @@ import Control.Monad.RWS.Lazy qualified import Control.Monad.RWS.Strict qualified import Control.Monad.Reader +import Data.Foldable (foldl') import Data.Map.Strict qualified as M import Futhark.IR.Pretty () import Futhark.IR.Prop.Types @@ -161,10 +162,21 @@ scopeOf = mconcat . map scopeOf instance Scoped rep (Stms rep) where - scopeOf = foldMap scopeOf + scopeOf = foldl' grow mempty + where + grow env' = extendWithPat env' . stmPat +-- A minor optimisation to avoid allocating scopes just to union them with other +-- scopes later. +extendWithPat :: Scope rep -> Pat (LetDec rep) -> Scope rep +extendWithPat env (Pat pes) = + foldl' + (\env' (PatElem name dec) -> M.insert name (LetName dec) env') + env + pes + instance Scoped rep (Stm rep) where - scopeOf = scopeOfPat . stmPat + scopeOf = extendWithPat mempty . stmPat instance Scoped rep (FunDef rep) where scopeOf = scopeOfFParams . funDefParams @@ -179,8 +191,7 @@ -- | The scope of a pattern. scopeOfPat :: (LetDec rep ~ dec) => Pat dec -> Scope rep -scopeOfPat = - mconcat . map scopeOfPatElem . patElems +scopeOfPat = extendWithPat mempty -- | The scope of a pattern element. scopeOfPatElem :: (LetDec rep ~ dec) => PatElem dec -> Scope rep diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs --- a/src/Futhark/IR/SOACS/Simplify.hs +++ b/src/Futhark/IR/SOACS/Simplify.hs @@ -32,6 +32,7 @@ import Data.Map.Strict qualified as M import Data.Maybe import Data.Set qualified as S +import Futhark.Analysis.Alias qualified as Alias import Futhark.Analysis.DataDependencies import Futhark.Analysis.SymbolTable qualified as ST import Futhark.Analysis.UsageTable qualified as UT @@ -46,6 +47,7 @@ import Futhark.Optimise.Simplify.Rules.ClosedForm import Futhark.Pass import Futhark.Tools +import Futhark.Transform.FirstOrderTransform qualified as FOT import Futhark.Transform.Rename import Futhark.Util @@ -617,7 +619,7 @@ -- For now we just remove singleton SOACs and those with unroll attributes. simplifyKnownIterationSOAC :: - (Buildable rep, BuilderOps rep, HasSOAC rep) => + (Buildable rep, BuilderOps rep, HasSOAC rep, Alias.AliasableRep rep) => TopDownRuleOp rep simplifyKnownIterationSOAC _ pat _ op | Just (Screma (Constant k) arrs (ScremaForm map_lam scans reds)) <- asSOAC op, @@ -675,16 +677,16 @@ certifying cs $ letBindNames [v] $ BasicOp $ SubExp se -- simplifyKnownIterationSOAC _ pat aux op - | Just (Screma (Constant (IntValue (Int64Value k))) arrs (ScremaForm map_lam [] [])) <- asSOAC op, - "unroll" `inAttrs` stmAuxAttrs aux = Simplify $ do - arrs_elems <- fmap transpose . forM [0 .. k - 1] $ \i -> do - map_lam' <- renameLambda map_lam - eLambda map_lam' $ map (`eIndex` [eSubExp (constant i)]) arrs - forM_ (zip3 (patNames pat) arrs_elems (lambdaReturnType map_lam)) $ - \(v, arr_elems, t) -> - certifying (mconcat (map resCerts arr_elems)) $ - letBindNames [v] . BasicOp $ - ArrayLit (map resSubExp arr_elems) t + | Just (Screma w arrs form) <- asSOAC op, + Constant (IntValue (Int64Value k)) <- w, + "unroll" `inAttrs` stmAuxAttrs aux = + Simplify $ + auxing aux $ + FOT.transformScrema + pat + (Constant (IntValue (Int64Value k))) + arrs + form -- simplifyKnownIterationSOAC _ _ _ _ = Skip diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs --- a/src/Futhark/IR/SegOp.hs +++ b/src/Futhark/IR/SegOp.hs @@ -923,7 +923,7 @@ -- Ensure we do not try to use anything that is consumed in the result. (body_res, body_stms, hoisted) <- - Engine.localVtable (<> scope_vtable) + Engine.localVtable (segSpaceSymbolTable space) . Engine.localVtable (\vtable -> vtable {ST.simplifyMemory = True}) . Engine.enterLoop $ Engine.blockIf blocker stms @@ -935,7 +935,6 @@ pure (mkWiseBody () body_stms body_res, hoisted) where - scope_vtable = segSpaceSymbolTable space bound_here = namesFromList $ M.keys $ scopeOfSegSpace space simplifyLambda :: @@ -945,9 +944,9 @@ Engine.SimpleM rep (Lambda (Wise rep), Stms (Wise rep)) simplifyLambda bound = Engine.blockMigrated . Engine.simplifyLambda bound -segSpaceSymbolTable :: (ASTRep rep) => SegSpace -> ST.SymbolTable rep -segSpaceSymbolTable (SegSpace flat gtids_and_dims) = - foldl' f (ST.fromScope $ M.singleton flat $ IndexName Int64) gtids_and_dims +segSpaceSymbolTable :: (ASTRep rep) => SegSpace -> ST.SymbolTable rep -> ST.SymbolTable rep +segSpaceSymbolTable (SegSpace flat gtids_and_dims) st = + foldl' f (ST.insertFreeVar flat (IndexName Int64) st) gtids_and_dims where f vtable (gtid, dim) = ST.insertLoopVar gtid Int64 dim vtable @@ -982,7 +981,7 @@ simplifySegOp (SegRed lvl space ts kbody reds) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts) (reds', reds_hoisted) <- - Engine.localVtable (<> scope_vtable) $ + Engine.localVtable (ST.insertScope scope) $ mapAndUnzipM (simplifySegBinOp (segFlat space)) reds (kbody', body_hoisted) <- simplifyKernelBody space kbody @@ -992,11 +991,10 @@ ) where scope = scopeOfSegSpace space - scope_vtable = ST.fromScope scope simplifySegOp (SegScan lvl space ts kbody scans) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts) (scans', scans_hoisted) <- - Engine.localVtable (<> scope_vtable) $ + Engine.localVtable (ST.insertScope scope) $ mapAndUnzipM (simplifySegBinOp (segFlat space)) scans (kbody', body_hoisted) <- simplifyKernelBody space kbody @@ -1006,7 +1004,6 @@ ) where scope = scopeOfSegSpace space - scope_vtable = ST.fromScope scope simplifySegOp (SegHist lvl space ts kbody ops) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts) @@ -1019,7 +1016,7 @@ nes' <- Engine.simplify nes dims' <- Engine.simplify dims (lam', op_hoisted) <- - Engine.localVtable (<> scope_vtable) $ + Engine.localVtable (ST.insertScope scope) $ Engine.localVtable (\vtable -> vtable {ST.simplifyMemory = True}) $ simplifyLambda (oneName (segFlat space)) lam pure @@ -1035,7 +1032,6 @@ ) where scope = scopeOfSegSpace space - scope_vtable = ST.fromScope scope -- | Does this rep contain 'SegOp's in its t'Op's? A rep must be an -- instance of this class for the simplification rules to work. diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -81,7 +81,7 @@ maybeLog "Lifting lambdas" prog_decs3 <- LiftLambdas.transformProg prog_decs2 maybeLog "Monomorphising" - prog_decs4 <- Monomorphise.transformProg prog_decs3 + (prog_decs4, _) <- Monomorphise.transformProg prog_decs3 maybeLog "Defunctionalising" prog_decs5 <- Defunctionalise.transformProg prog_decs4 maybeLog "Converting to core IR" 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 @@ -52,21 +52,18 @@ -- value. type Env = M.Map VName Binding -localEnv :: Env -> DefM a -> DefM a -localEnv env = local $ second (env <>) +localEnv :: (Env -> Env) -> DefM a -> DefM a +localEnv f = local $ second f -- Even when using a "new" environment (for evaluating closures) we -- still ram the global environment of DynamicFuns in there. localNewEnv :: Env -> DefM a -> DefM a -localNewEnv env = local $ \(globals, old_env) -> - (globals, M.filterWithKey (\k _ -> k `S.member` globals) old_env <> env) +localNewEnv env = local $ \(globals, _old_env) -> + (globals, globals <> env) askEnv :: DefM Env askEnv = asks snd -areGlobal :: [VName] -> DefM a -> DefM a -areGlobal vs = local $ first (S.fromList vs <>) - replaceTypeSizes :: M.Map VName SizeSubst -> TypeBase Size als -> @@ -163,7 +160,7 @@ restrict (globals, env) = M.mapMaybeWithKey keep env where keep k (Binding t sv) = do - guard $ not (k `S.member` globals) && S.member k (fvVars fv) + guard $ not (k `M.member` globals) && S.member k (fvVars fv) Just $ Binding t $ restrict' sv restrict' (Dynamic t) = Dynamic t @@ -179,17 +176,16 @@ restrict' (HoleSV t loc) = HoleSV t loc restrict'' (Binding t sv) = Binding t $ restrict' sv --- | Defunctionalization monad. The Reader environment tracks both --- the current Env as well as the set of globally defined dynamic --- functions. This is used to avoid unnecessarily large closure --- environments. +-- | Defunctionalization monad. The Reader environment tracks both the global +-- Env and the current Env. This is used to avoid unnecessarily large closure +-- environments (no need to capture the global one). newtype DefM a - = DefM (ReaderT (S.Set VName, Env) (State ([ValBind], VNameSource)) a) + = DefM (ReaderT (Env, Env) (State ([ValBind], VNameSource)) a) deriving ( Functor, Applicative, Monad, - MonadReader (S.Set VName, Env), + MonadReader (Env, Env), MonadState ([ValBind], VNameSource) ) @@ -244,7 +240,7 @@ case M.lookup x env of Just (Binding (Just (dims, sv_t)) sv) -> do globals <- asks fst - instStaticVal globals dims t sv_t sv + instStaticVal (M.keysSet globals) dims t sv_t sv Just (Binding Nothing sv) -> pure sv Nothing -- If the variable is unknown, it may refer to the 'intrinsics' @@ -557,9 +553,9 @@ | otherwise = defuncExp e0 defuncExp (AppExp (LetPat sizes pat e1 e2 loc) (Info (AppRes t retext))) = do (e1', sv1) <- defuncExp e1 - let env = alwaysMatchPatSV (fmap (toParam Observe) pat) sv1 + let extEnv env = alwaysMatchPatSV env (fmap (toParam Observe) pat) sv1 pat' = updatePat (fmap (toParam Observe) pat) sv1 - (e2', sv2) <- localEnv env $ defuncExp e2 + (e2', sv2) <- localEnv extEnv $ defuncExp e2 -- To maintain any sizes going out of scope, we need to compute the -- old size substitution induced by retext and also apply it to the -- newly computed body type. @@ -593,22 +589,26 @@ defuncExp IndexSection {} = error "defuncExp: unexpected projection section." defuncExp (AppExp (Loop sparams pat loopinit form e3 loc) res) = do (e1', sv1) <- defuncExp $ loopInitExp loopinit - let env1 = alwaysMatchPatSV pat sv1 + env <- askEnv + let env1 = alwaysMatchPatSV env pat sv1 (form', env2) <- case form of For v e2 -> do e2' <- defuncExp' e2 - pure (For v e2', envFromIdent v) + pure (For v e2', insertIdent v env1) ForIn pat2 e2 -> do e2' <- defuncExp' e2 - pure (ForIn pat2 e2', envFromPat $ fmap (toParam Observe) pat2) + pure + ( ForIn pat2 e2', + envFromPat env1 (fmap (toParam Observe) pat2) + ) While e2 -> do - e2' <- localEnv env1 $ defuncExp' e2 - pure (While e2', mempty) - (e3', sv) <- localEnv (env1 <> env2) $ defuncExp e3 + e2' <- local (second (const env1)) $ defuncExp' e2 + pure (While e2', env1) + (e3', sv) <- local (second (const env2)) $ defuncExp e3 pure (AppExp (Loop sparams pat (LoopInitExplicit e1') form' e3' loc) res, sv) where - envFromIdent (Ident vn (Info tp) _) = - M.singleton vn $ Binding Nothing $ Dynamic $ toParam Observe tp + insertIdent (Ident vn (Info tp) _) = + M.insert vn $ Binding Nothing $ Dynamic $ toParam Observe tp defuncExp e@(AppExp BinOp {} _) = error $ "defuncExp: unexpected binary operator: " ++ prettyString e defuncExp (Project vn e0 tp@(Info tp') loc) = do @@ -713,9 +713,10 @@ defuncCase :: StaticVal -> Case -> DefM (Maybe (Case, StaticVal)) defuncCase sv (CasePat p e loc) = do let p' = updatePat (fmap (toParam Observe) p) sv - case matchPatSV (fmap (toParam Observe) p) sv of - Just env -> do - (e', sv') <- localEnv env $ defuncExp e + env <- askEnv + case matchPatSV env (fmap (toParam Observe) p) sv of + Just env' -> do + (e', sv') <- local (second (const env')) $ defuncExp e pure $ Just (CasePat (fmap toStruct p') e' loc, sv') Nothing -> pure Nothing @@ -730,14 +731,16 @@ defuncSoacExp (Parens e loc) = Parens <$> defuncSoacExp e <*> pure loc defuncSoacExp (Lambda params e0 decl tp loc) = do - let env = foldMap envFromPat params - e0' <- localEnv env $ defuncSoacExp e0 + env <- askEnv + let env' = foldl' envFromPat env params + e0' <- local (second (const env')) $ defuncSoacExp e0 pure $ Lambda params e0' decl tp loc defuncSoacExp e | Scalar Arrow {} <- typeOf e = do (pats, body, tp) <- etaExpand (RetType [] $ toRes Nonunique $ typeOf e) e - let env = foldMap envFromPat pats - body' <- localEnv env $ defuncExp' body + env <- askEnv + let env' = foldl' envFromPat env pats + body' <- local (second (const env')) $ defuncExp' body pure $ Lambda pats body' Nothing (Info tp) (srclocOf e) | otherwise = defuncExp' e @@ -796,12 +799,13 @@ DefM ([VName], [Pat ParamType], Exp, StaticVal, ResType) defuncLet dims ps@(pat : pats) body (RetType ret_dims rettype) | patternOrderZero pat = do + env <- askEnv let bound_by_pat = (`S.member` fvVars (freeInPat pat)) -- Take care to not include more size parameters than necessary. (pat_dims, rest_dims) = partition bound_by_pat dims - env = envFromPat pat <> envFromDimNames pat_dims + env' = envFromPat env pat <> envFromDimNames pat_dims (rest_dims', pats', body', sv, sv_t) <- - localEnv env $ defuncLet rest_dims pats body $ RetType ret_dims rettype + local (second (const env')) $ defuncLet rest_dims pats body $ RetType ret_dims rettype closure <- defuncFun dims ps body (RetType ret_dims rettype) mempty pure ( pat_dims ++ rest_dims', @@ -833,7 +837,7 @@ instAnySizes = traverse $ traverse $ bitraverse onDim pure where onDim d - | d == anySize = do + | Just _ <- isAnySize d = do v <- newVName "size" pure $ sizeFromName (qualName v) mempty onDim d = pure d @@ -882,7 +886,7 @@ -- Ensure that no parameter sizes are AnySize. The internaliser -- expects this. This is easy, because they are all -- first-order. - globals <- asks fst + globals <- asks $ M.keysSet . fst let bound_sizes = S.fromList dims' <> globals pats' <- instAnySizes pats let dims'' = dims' ++ unboundSizes bound_sizes pats' @@ -916,16 +920,16 @@ DefM (Exp, StaticVal) defuncApplyArg (fname_s, floc) (f', LambdaSV pat lam_e_t lam_e closure_env) ((argext, arg), _) = do (arg', arg_sv) <- defuncExp arg - let env' = alwaysMatchPatSV pat arg_sv + let env' = alwaysMatchPatSV closure_env pat arg_sv dims = mempty (lam_e', sv) <- - localNewEnv (env' <> closure_env) $ + localNewEnv env' $ defuncExp lam_e let closure_pat = buildEnvPat dims closure_env pat' = updatePat pat arg_sv - globals <- asks fst + globals <- asks $ M.keysSet . fst -- Lift lambda to top-level function definition. We put in -- a lot of effort to try to infer the uniqueness attributes @@ -1053,17 +1057,17 @@ -- | Converts a pattern to an environment that binds the individual names of the -- pattern to their corresponding types wrapped in a 'Dynamic' static value. -envFromPat :: Pat ParamType -> Env -envFromPat pat = case pat of - TuplePat ps _ -> foldMap envFromPat ps - RecordPat fs _ -> foldMap (envFromPat . snd) fs - PatParens p _ -> envFromPat p - PatAttr _ p _ -> envFromPat p - Id vn (Info t) _ -> M.singleton vn $ Binding Nothing $ Dynamic t - Wildcard _ _ -> mempty - PatAscription p _ _ -> envFromPat p - PatLit {} -> mempty - PatConstr _ _ ps _ -> foldMap envFromPat ps +envFromPat :: Env -> Pat ParamType -> Env +envFromPat env pat = case pat of + TuplePat ps _ -> foldl' envFromPat env ps + RecordPat fs _ -> foldl' envFromPat env $ map snd fs + PatParens p _ -> envFromPat env p + PatAttr _ p _ -> envFromPat env p + Id vn (Info t) _ -> M.insert vn (Binding Nothing $ Dynamic t) env + Wildcard _ _ -> env + PatAscription p _ _ -> envFromPat env p + PatLit {} -> env + PatConstr _ _ ps _ -> foldl' envFromPat env ps -- | Given a closure environment, construct a record pattern that -- binds the closed over variables. Insert wildcard for any patterns @@ -1122,24 +1126,24 @@ -- corresponding subcomponents of the static value. If this function -- returns 'Nothing', then it corresponds to an unmatchable case. -- These should only occur for 'Match' expressions. -matchPatSV :: Pat ParamType -> StaticVal -> Maybe Env -matchPatSV (TuplePat ps _) (RecordSV ls) = - mconcat <$> zipWithM (\p (_, sv) -> matchPatSV p sv) ps ls -matchPatSV (RecordPat ps _) (RecordSV ls) +matchPatSV :: Env -> Pat ParamType -> StaticVal -> Maybe Env +matchPatSV env (TuplePat ps _) (RecordSV ls) = + foldM (\env' (p, (_, sv)) -> matchPatSV env' p sv) env $ zip ps ls +matchPatSV env (RecordPat ps _) (RecordSV ls) | ps' <- sortOn fst $ map (first unLoc) ps, ls' <- sortOn fst ls, map fst ps' == map fst ls' = - mconcat <$> zipWithM (\(_, p) (_, sv) -> matchPatSV p sv) ps' ls' -matchPatSV (PatParens pat _) sv = matchPatSV pat sv -matchPatSV (PatAttr _ pat _) sv = matchPatSV pat sv -matchPatSV (Id vn (Info t) _) sv = + foldM (\env' ((_, p), (_, sv)) -> matchPatSV env' p sv) env $ zip ps' ls' +matchPatSV env (PatParens pat _) sv = matchPatSV env pat sv +matchPatSV env (PatAttr _ pat _) sv = matchPatSV env pat sv +matchPatSV env (Id vn (Info t) _) sv = -- When matching a zero-order pattern with a StaticVal, the type of -- the pattern wins out. This is important for propagating sizes -- (but probably reveals a flaw in our bookkeeping). pure $ if orderZero t - then dim_env <> M.singleton vn (Binding Nothing $ Dynamic t) - else dim_env <> M.singleton vn (Binding Nothing sv) + then dim_env <> M.insert vn (Binding Nothing $ Dynamic t) env + else dim_env <> M.insert vn (Binding Nothing sv) env where -- Extract all sizes that are potentially bound here. This is -- different from all free variables (see #2040). @@ -1147,35 +1151,35 @@ onDim (Var v _ _) = M.singleton (qualLeaf v) i64 onDim _ = mempty i64 = Binding Nothing $ Dynamic $ Scalar $ Prim $ Signed Int64 -matchPatSV (Wildcard _ _) _ = pure mempty -matchPatSV (PatAscription pat _ _) sv = matchPatSV pat sv -matchPatSV PatLit {} _ = pure mempty -matchPatSV (PatConstr c1 _ ps _) (SumSV c2 ls fs) +matchPatSV env (Wildcard _ _) _ = Just env +matchPatSV env (PatAscription pat _ _) sv = matchPatSV env pat sv +matchPatSV env PatLit {} _ = Just env +matchPatSV env (PatConstr c1 _ ps _) (SumSV c2 ls fs) | c1 == c2 = - mconcat <$> zipWithM matchPatSV ps ls + foldM (\env' (p, l) -> matchPatSV env' p l) env $ zip ps ls | Just _ <- lookup c1 fs = Nothing | otherwise = error $ "matchPatSV: missing constructor in type: " ++ prettyString c1 -matchPatSV (PatConstr c1 _ ps _) (Dynamic (Scalar (Sum fs))) +matchPatSV env (PatConstr c1 _ ps _) (Dynamic (Scalar (Sum fs))) | Just ts <- M.lookup c1 fs = -- A higher-order pattern can only match an appropriate SumSV. if all orderZero ts - then mconcat <$> zipWithM matchPatSV ps (map svFromType ts) + then foldM (\env' (p, sv) -> matchPatSV env' p sv) env $ zip ps $ map svFromType ts else Nothing | otherwise = error $ "matchPatSV: missing constructor in type: " ++ prettyString c1 -matchPatSV pat (Dynamic t) = matchPatSV pat $ svFromType t -matchPatSV pat (HoleSV t _) = matchPatSV pat $ svFromType $ toParam Observe t -matchPatSV pat sv = +matchPatSV env pat (Dynamic t) = matchPatSV env pat $ svFromType t +matchPatSV env pat (HoleSV t _) = matchPatSV env pat $ svFromType $ toParam Observe t +matchPatSV _ pat sv = error $ "Tried to match pattern\n" ++ prettyString pat ++ "\n with static value\n" ++ show sv -alwaysMatchPatSV :: Pat ParamType -> StaticVal -> Env -alwaysMatchPatSV pat sv = fromMaybe bad $ matchPatSV pat sv +alwaysMatchPatSV :: Env -> Pat ParamType -> StaticVal -> Env +alwaysMatchPatSV env pat sv = fromMaybe bad $ matchPatSV env pat sv where bad = error $ unlines [prettyString pat, "cannot match StaticVal", show sv] @@ -1263,7 +1267,7 @@ ++ "but the defunctionaliser expects a monomorphic input program." (tparams', params', body', sv, sv_t) <- defuncLet (map typeParamName tparams) params body $ RetType ret_dims rettype - globals <- asks fst + globals <- asks $ M.keysSet . fst let bound_sizes = S.fromList (foldMap patNames params') <> S.fromList tparams' <> globals params'' <- instAnySizes params' let rettype' = combineTypeShapes rettype sv_t @@ -1294,8 +1298,7 @@ defuncVals (valbind : ds) = do (valbind', env) <- defuncValBind valbind addValBind valbind' - let globals = valBindBound valbind' - localEnv env $ areGlobal globals $ defuncVals ds + local (bimap (env <>) (env <>)) $ defuncVals ds {-# NOINLINE transformProg #-} diff --git a/src/Futhark/Internalise/Entry.hs b/src/Futhark/Internalise/Entry.hs --- a/src/Futhark/Internalise/Entry.hs +++ b/src/Futhark/Internalise/Entry.hs @@ -144,7 +144,7 @@ opaqueField (E.EntryType e_t _) i_ts = snd <$> entryPointType types (E.EntryType e_t' Nothing) i_ts where - e_t' = E.arrayOf (E.Shape (replicate rank E.anySize)) e_t + e_t' = E.arrayOf (E.Shape (replicate rank $ E.anySize 0)) e_t isSum :: VisibleTypes -> diff --git a/src/Futhark/Internalise/Exps.hs b/src/Futhark/Internalise/Exps.hs --- a/src/Futhark/Internalise/Exps.hs +++ b/src/Futhark/Internalise/Exps.hs @@ -563,14 +563,6 @@ loop_initial_cond : mergeinit ) ) -internaliseAppExp desc _ (E.LetWith name src idxs ve body loc) = do - let pat = E.Id (E.identName name) (E.identType name) loc - src_t = E.identType src - e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc - internaliseExp desc $ - E.AppExp - (E.LetPat [] pat e body loc) - (Info (AppRes (E.typeOf body) mempty)) internaliseAppExp desc _ (E.Match e orig_cs _) = do ses <- internaliseExp (desc <> "_scrutinee") e cs <- mapM (onCase ses) orig_cs @@ -593,6 +585,8 @@ (internaliseBody (desc <> "_f") fe) internaliseAppExp _ _ e@E.BinOp {} = error $ "internaliseAppExp: Unexpected BinOp " ++ prettyString e +internaliseAppExp _ _ e@(E.LetWith {}) = + error $ "internaliseAppExp: Unexpected LetWith at " ++ locStr (srclocOf e) internaliseExp :: Name -> E.Exp -> InternaliseM [I.SubExp] internaliseExp desc (E.Parens e _) = @@ -2145,7 +2139,7 @@ sizeExpForError :: E.Size -> InternaliseM [ErrorMsgPart SubExp] sizeExpForError e - | e == anySize = pure ["[]"] + | Just _ <- isAnySize e = pure ["[]"] | otherwise = do e' <- internaliseExp1 "size" e pure ["[", ErrorVal int64 e', "]"] diff --git a/src/Futhark/Internalise/FullNormalise.hs b/src/Futhark/Internalise/FullNormalise.hs --- a/src/Futhark/Internalise/FullNormalise.hs +++ b/src/Futhark/Internalise/FullNormalise.hs @@ -28,6 +28,7 @@ import Data.Text qualified as T import Futhark.MonadFreshNames import Futhark.Util (showText) +import Futhark.Util.Loc (srcspan) import Language.Futhark import Language.Futhark.Traversals import Language.Futhark.TypeChecker.Types @@ -326,10 +327,13 @@ where isOr = baseName (qualLeaf op) == "||" isAnd = baseName (qualLeaf op) == "&&" -getOrdering final (AppExp (LetWith (Ident dest dty dloc) (Ident src sty sloc) slice e body loc) _) = do +getOrdering final (AppExp (LetWith (Ident dest dty dloc) (Ident src sty sloc) slice e body _) _) = do e' <- getOrdering False e slice' <- astMap mapper slice - addBind $ PatBind [] (Id dest dty dloc) (Update (Var (qualName src) sty sloc) slice' e' loc) + -- Carefully synthesize a location that does not have the body in it - + -- this is so profiling information will be more precise. + let loc' = srcspan dloc e + addBind $ PatBind [] (Id dest dty dloc) (Update (Var (qualName src) sty sloc) slice' e' loc') getOrdering final body where mapper = identityMapper {mapOnExp = getOrdering False} 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 @@ -21,21 +21,27 @@ -- -- Note that these changes are unfortunately not visible in the AST -- representation. -module Futhark.Internalise.Monomorphise (transformProg) where +module Futhark.Internalise.Monomorphise + ( transformProg, + MonoType, + MonoStats, + ) +where import Control.Monad import Control.Monad.Identity -import Control.Monad.RWS (MonadReader (..), MonadWriter (..), RWST, asks, runRWST) +import Control.Monad.Reader import Control.Monad.State -import Control.Monad.Writer (Writer, runWriter, runWriterT) +import Control.Monad.Writer import Data.Bifunctor import Data.Bitraversable import Data.Foldable -import Data.List (partition) +import Data.Function +import Data.List (intersperse, partition, sortBy) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as M import Data.Maybe (isJust, isNothing) -import Data.Sequence qualified as Seq +import Data.Ord (Down (..), comparing) import Data.Set qualified as S import Futhark.MonadFreshNames import Futhark.Util (nubOrd, topologicalSort) @@ -136,21 +142,20 @@ envParametrized :: ExpReplacements } -instance Semigroup Env where - Env pb1 sc1 gs1 pr1 <> Env pb2 sc2 gs2 pr2 = Env (pb1 <> pb2) (sc1 <> sc2) (gs1 <> gs2) (pr1 <> pr2) - -instance Monoid Env where - mempty = Env mempty mempty mempty mempty - -localEnv :: Env -> MonoM a -> MonoM a -localEnv env = local (env <>) - isolateNormalisation :: MonoM a -> MonoM a isolateNormalisation m = do - prevRepl <- get - put mempty - ret <- local (\env -> env {envScope = mempty, envParametrized = mempty}) m - put prevRepl + prevRepl <- getExpReplacements + putExpReplacements mempty + ret <- + local + ( \env -> + env + { envScope = envGlobalScope env <> M.keysSet (envPolyBindings env), + envParametrized = mempty + } + ) + m + putExpReplacements prevRepl pure ret -- | These now have monomorphic types in the given action. This is @@ -163,41 +168,47 @@ keep v _ = v `notElem` vs withArgs :: S.Set VName -> MonoM a -> MonoM a -withArgs args = localEnv $ mempty {envScope = args} +withArgs args = local $ \env -> env {envScope = args <> envScope env} withParams :: ExpReplacements -> MonoM a -> MonoM a -withParams params = localEnv $ mempty {envParametrized = params} +withParams params = local $ \env -> env {envParametrized = params <> envParametrized env} +-- Mapping from function name and instance list to a new function name in case +-- the function has already been instantiated with those concrete types. +type Lifts = M.Map (VName, MonoType) (VName, InferSizeArgs) + +data MonoState = MonoState + { sVNameSource :: !VNameSource, + sExpReplacements :: ExpReplacements, + sLifts :: Lifts, + sLiftedNames :: S.Set VName, + sValBinds :: [ValBind] + } + -- The monomorphization monad. newtype MonoM a - = MonoM - ( RWST - Env - (Seq.Seq (VName, ValBind)) - (ExpReplacements, VNameSource) - (State Lifts) - a - ) + = MonoM (ReaderT Env (State MonoState) a) deriving ( Functor, Applicative, Monad, MonadReader Env, - MonadWriter (Seq.Seq (VName, ValBind)) + MonadState MonoState ) instance MonadFreshNames MonoM where - getNameSource = MonoM $ gets snd - putNameSource = MonoM . modify . second . const - -instance MonadState ExpReplacements MonoM where - get = MonoM $ gets fst - put = MonoM . modify . first . const + getNameSource = gets sVNameSource + putNameSource src = modify $ \s -> s {sVNameSource = src} -runMonoM :: VNameSource -> MonoM a -> ((a, Seq.Seq (VName, ValBind)), VNameSource) -runMonoM src (MonoM m) = ((a, defs), src') +runMonoM :: VNameSource -> MonoM () -> (([ValBind], Lifts), VNameSource) +runMonoM src (MonoM m) = + ( (reverse (sValBinds final_state), sLifts final_state), + sVNameSource final_state + ) where - (a, (_, src'), defs) = evalState (runRWST m mempty (mempty, src)) mempty + ((), final_state) = runState (runReaderT m initial_env) initial_state + initial_state = MonoState src mempty mempty mempty mempty + initial_env = Env mempty mempty mempty mempty lookupFun :: VName -> MonoM (Maybe PolyBinding) lookupFun vn = do @@ -206,13 +217,35 @@ Just valbind -> pure $ Just valbind Nothing -> pure Nothing +addValBind :: ValBind -> MonoM () +addValBind funbind = + modify $ \s -> s {sValBinds = funbind : sValBinds s} + askScope :: MonoM (S.Set VName) askScope = do scope <- asks envScope - scope' <- asks $ S.union scope . envGlobalScope - scope'' <- asks $ S.union scope' . M.keysSet . envPolyBindings - S.union scope'' . S.fromList . map (fst . snd) <$> getLifts + gets $ S.union scope . sLiftedNames +getExpReplacements :: MonoM ExpReplacements +getExpReplacements = gets sExpReplacements + +putExpReplacements :: ExpReplacements -> MonoM () +putExpReplacements x = modify $ \s -> s {sExpReplacements = x} + +getLifts :: MonoM Lifts +getLifts = gets sLifts + +addLifted :: VName -> MonoType -> (VName, InferSizeArgs) -> MonoM () +addLifted fname il liftf = + modify $ \s -> + s + { sLifts = M.insert (fname, il) liftf (sLifts s), + sLiftedNames = S.insert (fst liftf) $ sLiftedNames s + } + +lookupLifted :: VName -> MonoType -> MonoM (Maybe (VName, InferSizeArgs)) +lookupLifted fname t = M.lookup (fname, t) <$> getLifts + -- | Asks the introduced variables in a set of argument, -- that is arguments not currently in scope. askIntros :: S.Set VName -> MonoM (S.Set VName) @@ -228,8 +261,9 @@ parametrizing argset = do intros <- askIntros argset let usesIntros = not . S.disjoint intros . fvVars . freeInExp - (params, nxtBind) <- gets $ partition (usesIntros . unReplaced . fst) - put nxtBind + (params, nxtBind) <- + partition (usesIntros . unReplaced . fst) <$> getExpReplacements + putExpReplacements nxtBind pure params calculateDims :: Exp -> ExpReplacements -> MonoM Exp @@ -280,7 +314,7 @@ data MonoSize = MonoKnown Int | MonoAnon Int - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance Pretty MonoSize where pretty (MonoKnown i) = "?" <> pretty i @@ -289,9 +323,9 @@ instance Pretty (Shape MonoSize) where pretty (Shape ds) = mconcat (map (brackets . pretty) 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 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. type MonoType = TypeBase MonoSize NoUniqueness monoType :: TypeBase Size als -> MonoType @@ -322,27 +356,12 @@ Just prev -> pure $ MonoKnown prev Nothing -> do - -- Ensure that each instance of anySize is treated distinctly. - put (i + 1, if d == anySize then m else M.insert d i m) + 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. -type Lifts = [((VName, MonoType), (VName, InferSizeArgs))] - -getLifts :: MonoM Lifts -getLifts = MonoM $ lift get - -modifyLifts :: (Lifts -> Lifts) -> MonoM () -modifyLifts = MonoM . lift . modify - -addLifted :: VName -> MonoType -> (VName, InferSizeArgs) -> MonoM () -addLifted fname il liftf = - modifyLifts (((fname, il), liftf) :) - -lookupLifted :: VName -> MonoType -> MonoM (Maybe (VName, InferSizeArgs)) -lookupLifted fname t = lookup (fname, t) <$> getLifts - sizeVarName :: Exp -> Name sizeVarName e = "d<{" <> nameFromText (prettyText (bareExp e)) <> "}>" @@ -354,14 +373,14 @@ Just e' -> pure e' Nothing -> do let e' = ReplacedExp e - prev <- gets $ lookup e' + prev <- lookup e' <$> getExpReplacements prev_param <- asks $ lookup e' . envParametrized case (prev_param, prev) of (Just vn, _) -> pure $ sizeFromName (qualName vn) (srclocOf e) (Nothing, Just vn) -> pure $ sizeFromName (qualName vn) (srclocOf e) (Nothing, Nothing) -> do vn <- newVName $ sizeVarName e - modify ((e', vn) :) + putExpReplacements . ((e', vn) :) =<< getExpReplacements pure $ sizeFromName (qualName vn) (srclocOf e) where -- Avoid replacing of some 'already normalised' sizes that are just surounded by some parentheses. @@ -389,7 +408,7 @@ -- A polymorphic function. (Nothing, Just funbind) -> do (fname', infer, funbind') <- monomorphiseBinding funbind mono_t - tell $ Seq.singleton (qualLeaf fname, funbind') + addValBind funbind' addLifted (qualLeaf fname) mono_t (fname', infer) applySizeArgs fname' (toRes Nonunique t') <$> infer t' where @@ -445,7 +464,7 @@ transformScalarSizes ty@Prim {} = pure ty onDim e - | e == anySize = pure e + | Just _ <- isAnySize e = pure e | otherwise = replaceExp =<< transformExp e transformRetTypeSizes :: S.Set VName -> RetTypeBase Size as -> MonoM (RetTypeBase Size as) @@ -458,13 +477,18 @@ sizesForPat :: (MonadFreshNames m) => Pat ParamType -> m ([VName], Pat ParamType) sizesForPat pat = do (params', sizes) <- runStateT (traverse (bitraverse onDim pure) pat) [] - pure (sizes, params') + pure (map snd sizes, params') where onDim d - | d == anySize = do - v <- lift $ newVName "size" - modify (v :) - pure $ sizeFromName (qualName v) mempty + | Just k <- isAnySize d = do + prev <- gets $ lookup k + case prev of + Nothing -> do + v <- lift $ newVName "size" + modify ((k, v) :) + pure $ sizeFromName (qualName v) mempty + Just v -> + pure $ sizeFromName (qualName v) mempty | otherwise = pure d transformAppRes :: AppRes -> MonoM AppRes @@ -860,7 +884,7 @@ inferSizeArgs :: [TypeParam] -> StructType -> ExpReplacements -> StructType -> MonoM [Exp] inferSizeArgs tparams bind_t bind_r t = do - r <- gets (<>) <*> asks envParametrized + r <- (<>) <$> getExpReplacements <*> asks envParametrized let dinst = dimMapping bind_t t bind_r r mapM (tparamArg dinst) tparams where @@ -871,7 +895,7 @@ -- only occurs when those sizes don't actually matter (knock -- on wood...), but we should never actually insert anySize -- as a concrete argument. - | e /= anySize -> + | Nothing <- isAnySize e -> replaceExp e _ -> pure $ sizeFromInteger 0 mempty @@ -938,10 +962,9 @@ notIntrisic vn = baseTag vn > maxIntrinsicTag argset' = fvVars $ freeInType argT fullArgset = - argset' - <> case argName of - Unnamed -> mempty - Named vn -> S.singleton vn + case argName of + Unnamed -> argset' + Named vn -> S.insert vn argset' arrowArgScalar env (TypeVar u qn args) = TypeVar u qn <$> mapM arrowArgArg args where @@ -1003,7 +1026,7 @@ substTypesAny (fmap (fmap (second (const mempty))) . (`M.lookup` substs')) params' = map (substPat substStructType) params params'' <- withArgs shape_names $ mapM transformPat params' - exp_naming <- get <* put mempty + exp_naming <- getExpReplacements <* putExpReplacements mempty let args = S.fromList $ foldMap patNames params arg_params = map snd exp_naming @@ -1012,7 +1035,7 @@ withParams exp_naming $ withArgs (args <> shape_names) $ hardTransformRetType (applySubst (`M.lookup` substs') rettype) - extNaming <- get <* put mempty + extNaming <- getExpReplacements <* putExpReplacements mempty scope <- S.union shape_names <$> askScope' let (rettype'', new_params) = arrowArg scope args arg_params rettype' bind_t' = substTypesAny (`M.lookup` substs') bind_t @@ -1031,9 +1054,9 @@ body'' <- withParams exp_naming' $ withArgs (shape_names <> args) $ transformExp body' scope' <- S.union (shape_names <> args) <$> askScope' body''' <- - expReplace exp_naming' <$> (calculateDims body'' . canCalculate scope' =<< get) + expReplace exp_naming' <$> (calculateDims body'' . canCalculate scope' =<< getExpReplacements) - seen_before <- elem name . map (fst . fst) <$> getLifts + seen_before <- elem name . map fst . M.keys <$> getLifts name' <- if null tparams && isNothing entry && not seen_before then pure name @@ -1161,7 +1184,7 @@ onDim (MonoAnon i) = do (_, sizes) <- get case M.lookup i sizes of - Nothing -> pure anySize + Nothing -> pure $ anySize i Just d -> pure d -- Perform a given substitution on the types in a pattern. @@ -1193,27 +1216,57 @@ unInfo $ valBindRetType valbind (name, infer, valbind'') <- monomorphiseBinding valbind' $ monoType t - tell $ Seq.singleton (name, valbind'') + addValBind valbind'' addLifted (valBindName valbind) (monoType t) (name, infer) + let global = + if null (valBindParams valbind) + then S.fromList $ retDims $ unInfo $ valBindRetType valbind + else mempty + + env <- ask + pure - mempty - { envPolyBindings = M.singleton (valBindName valbind) valbind', - envGlobalScope = - if null (valBindParams valbind) - then S.fromList $ retDims $ unInfo $ valBindRetType valbind - else mempty + env + { envPolyBindings = M.insert (valBindName valbind) valbind' $ envPolyBindings env, + envGlobalScope = global <> envGlobalScope env, + envScope = + S.insert (valBindName valbind) global + <> envScope env } transformValBinds :: [ValBind] -> MonoM () transformValBinds [] = pure () transformValBinds (valbind : ds) = do env <- transformValBind valbind - localEnv env $ transformValBinds ds + local (const env) $ transformValBinds ds +-- | Statistics about which functions were monomorphised. +newtype MonoStats = MonoStats [(VName, [MonoType])] + +instance Pretty MonoStats where + pretty (MonoStats l) = + stack $ intersperse "" $ map pf l + where + comment = ("-- " <>) + pf (name, ts) = + comment (pretty (baseName name) <> "_" <> pretty (baseTag name)) + <+> parens (pretty (length ts) <+> "instantiations") + <> ":" + stack (map (comment . indent 2 . pretty) ts) + -- | Monomorphise a list of top-level value bindings. -transformProg :: (MonadFreshNames m) => [ValBind] -> m [ValBind] -transformProg decs = - fmap (toList . fmap snd . snd) $ +transformProg :: (MonadFreshNames m) => [ValBind] -> m ([ValBind], MonoStats) +transformProg decs = do + (a, b) <- modifyNameSource $ \namesrc -> runMonoM namesrc $ transformValBinds decs + pure + ( toList a, + MonoStats . sortBy (comparing (Down . length . snd)) $ + map (\l -> (fst (NE.head l), NE.toList $ fmap snd l)) $ + NE.groupBy ((==) `on` fst) $ + sortBy (comparing fst) $ + map fst $ + M.toList b + ) diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs --- a/src/Futhark/Internalise/TypesValues.hs +++ b/src/Futhark/Internalise/TypesValues.hs @@ -218,7 +218,7 @@ InternaliseTypeM ExtSize internaliseDim exts d = case d of - e | e == E.anySize -> Ext <$> newId + e | Just _ <- E.isAnySize e -> Ext <$> newId (E.IntLit n _ _) -> pure $ I.Free $ intConst I.Int64 n (E.Var name _ _) -> pure $ namedDim name e -> error $ "Unexpected size expression: " ++ prettyString e diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs --- a/src/Futhark/Optimise/InliningDeadFun.hs +++ b/src/Futhark/Optimise/InliningDeadFun.hs @@ -87,7 +87,7 @@ consts' <- simplifyConsts . performCSEOnStms =<< inlineInStms inlinemap consts - pure (ST.insertStms (informStms consts') mempty, consts') + pure (ST.insertStms (informStms consts') ST.empty, consts') else pure (vtable, consts) let simplifyFun' fd diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs --- a/src/Futhark/Optimise/Simplify.hs +++ b/src/Futhark/Optimise/Simplify.hs @@ -51,13 +51,13 @@ let consts = progConsts prog funs = progFuns prog (consts_vtable, consts') <- - simplifyConsts (funDefUsages funs) (mempty, informStms consts) + simplifyConsts (funDefUsages funs) (ST.empty, informStms consts) -- We deepen the vtable so it will look like the constants are in an -- "outer loop"; this communicates useful information to some -- simplification rules (e.g. see issue #1302). funs' <- parPass (simplifyFun' (ST.deepen consts_vtable) . informFunDef) funs - (_, consts'') <- simplifyConsts (funDefUsages funs') (mempty, consts') + (_, consts'') <- simplifyConsts (funDefUsages funs') (ST.empty, consts') pure $ prog @@ -67,12 +67,12 @@ where simplifyFun' consts_vtable = simplifySomething - (Engine.localVtable (consts_vtable <>) . Engine.simplifyFun) + (Engine.localVtable (const consts_vtable) . Engine.simplifyFun) id simpl rules blockers - mempty + ST.empty simplifyConsts uses = simplifySomething @@ -81,11 +81,11 @@ simpl rules blockers - mempty + ST.empty onConsts uses consts' = do consts'' <- Engine.simplifyStmsWithUsage uses consts' - pure (ST.insertStms consts'' mempty, consts'') + pure (ST.insertStms consts'' ST.empty, consts'') -- | Run a simplification operation to convergence. simplifySomething :: @@ -99,7 +99,7 @@ a -> m a simplifySomething f g simpl rules blockers vtable x = do - let f' x' = Engine.localVtable (vtable <>) $ f x' + let f' x' = Engine.localVtable (const vtable) $ f x' loopUntilConvergence env simpl f' g x where env = Engine.emptyEnv rules blockers diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -109,7 +109,7 @@ Env { envRules = rules, envHoistBlockers = blockers, - envVtable = mempty + envVtable = ST.empty } -- | A function that protects a hoisted operation (if possible). The @@ -185,7 +185,7 @@ (SimplifiableRep rep) => LocalScope (Wise rep) (SimpleM rep) where - localScope types = localVtable (<> ST.fromScope types) + localScope types = localVtable (ST.insertScope types) runSimpleM :: SimpleM rep a -> diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs --- a/src/Futhark/Optimise/Simplify/Rules.hs +++ b/src/Futhark/Optimise/Simplify/Rules.hs @@ -38,7 +38,7 @@ topDownRules = [ RuleGeneric constantFoldPrimFun, RuleGeneric withAccTopDown, - RuleGeneric emptyArrayToScratch + RuleGeneric toScratch ] bottomUpRules :: (BuilderOps rep, TraverseOpStms rep) => [BottomUpRule rep] @@ -110,17 +110,37 @@ isConst _ = Nothing constantFoldPrimFun _ _ = Skip --- | If an expression produces an array with a constant zero anywhere --- in its shape, just turn that into a Scratch. -emptyArrayToScratch :: (BuilderOps rep) => TopDownRuleGeneric rep -emptyArrayToScratch _ (Let pat@(Pat [pe]) aux e) - | Just (pt, shape) <- isEmptyArray $ patElemType pe, - not $ isScratch e = +isScratch :: Exp rep -> Bool +isScratch (BasicOp Scratch {}) = True +isScratch _ = False + +-- | Some expressions can never produce a meaningful value - these we turn into +-- Scratch, and maybe that helps remove more code. +toScratch :: (BuilderOps rep) => TopDownRuleGeneric rep +-- If an expression produces an array with a constant zero anywhere in its +-- shape, just turn that into a Scratch. +toScratch _ (Let pat@(Pat [pe]) aux e) + | not $ isScratch e, + Just (pt, shape) <- isEmptyArray $ patElemType pe = Simplify $ auxing aux $ letBind pat $ BasicOp $ Scratch pt $ shapeDims shape +-- If we depend on a certificate that is constant False (and so will always +-- fail), then clearly there is no need to compute this. +toScratch vtable (Let pat aux e) + | any doomed $ unCerts $ stmAuxCerts aux, + not $ isScratch e, + not $ isConst e, + not $ any accOrMem $ patTypes pat = + Simplify . auxing aux $ + forM_ (zip (patNames pat) (patTypes pat)) $ \(v, t) -> + letBindNames [v] =<< eBlank t where - isScratch (BasicOp Scratch {}) = True - isScratch _ = False -emptyArrayToScratch _ _ = Skip + doomed v = case ST.lookupBasicOp v vtable of + Just (Assert (Constant (BoolValue False)) _, _) -> True + _ -> False + accOrMem t = isAcc t || isMem t + isConst (BasicOp (SubExp (Constant _))) = True + isConst _ = False +toScratch _ _ = Skip simplifyIndex :: (BuilderOps rep) => BottomUpRuleBasicOp rep simplifyIndex (vtable, used) pat@(Pat [pe]) aux (Index idd inds) diff --git a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs --- a/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +++ b/src/Futhark/Optimise/Simplify/Rules/BasicOp.hs @@ -146,7 +146,7 @@ ruleBasicOp :: (BuilderOps rep) => TopDownRuleBasicOp rep ruleBasicOp vtable pat aux op | Just (op', cs) <- applySimpleRules defOf seType op = - Simplify $ certifying (cs <> stmAuxCerts aux) $ letBind pat $ BasicOp op' + Simplify $ auxing aux $ certifying cs $ letBind pat $ BasicOp op' where defOf = (`ST.lookupExp` vtable) seType (Var v) = ST.lookupType v vtable diff --git a/src/Futhark/Optimise/Simplify/Rules/Index.hs b/src/Futhark/Optimise/Simplify/Rules/Index.hs --- a/src/Futhark/Optimise/Simplify/Rules/Index.hs +++ b/src/Futhark/Optimise/Simplify/Rules/Index.hs @@ -68,6 +68,12 @@ where isIndex DimFix {} = True isIndex _ = False + Just (Scratch pt _, cs) -> + -- Indexing a Scratch just becomes a different scratch. + Just $ + fmap (SubExpResult cs) + . letSubExp (baseName idd <> "_idx") + =<< eBlank (arrayOfShape (Prim pt) (sliceShape $ Slice inds)) _ | Just t <- seType (Var idd), Slice inds == fullSlice t [] -> diff --git a/src/Futhark/Optimise/Sink.hs b/src/Futhark/Optimise/Sink.hs --- a/src/Futhark/Optimise/Sink.hs +++ b/src/Futhark/Optimise/Sink.hs @@ -118,7 +118,7 @@ scope = case form of WhileLoop {} -> scopeOfFParams params ForLoop i it _ -> M.insert i (IndexName it) $ scopeOfFParams params - vtable' = ST.fromScope scope <> vtable + vtable' = ST.insertScope scope vtable optimiseStms :: (Constraints rep) => @@ -189,7 +189,7 @@ let (body', sunk) = optimiseBody onOp - (ST.fromScope scope <> vtable) + (ST.insertScope scope vtable) sinking body modify (<> sunk) @@ -235,7 +235,7 @@ pure body' } where - op_vtable = ST.fromScope scope <> vtable + op_vtable = ST.insertScope scope vtable type SinkRep rep = Aliases rep @@ -253,14 +253,14 @@ . Alias.aliasAnalysis where onFun _ fd = do - let vtable = ST.insertFParams (funDefParams fd) mempty + let vtable = ST.insertFParams (funDefParams fd) ST.empty (body, _) = optimiseBody onOp vtable mempty $ funDefBody fd pure fd {funDefBody = body} onConsts consts = pure $ fst $ - optimiseStms onOp mempty mempty consts $ + optimiseStms onOp ST.empty mempty consts $ namesFromList $ M.keys $ scopeOf consts diff --git a/src/Futhark/Pkg/Info.hs b/src/Futhark/Pkg/Info.hs --- a/src/Futhark/Pkg/Info.hs +++ b/src/Futhark/Pkg/Info.hs @@ -18,7 +18,7 @@ ) where -import Control.Monad (unless, void) +import Control.Monad (unless, void, (<=<)) import Control.Monad.IO.Class import Data.ByteString qualified as BS import Data.IORef @@ -162,25 +162,30 @@ FilePath -> PkgPath -> Ref -> - m (PkgRevInfo m) + m (Maybe (PkgRevInfo m)) revInfo gitdir path ref = do gitCmd_ ["-C", gitdir, "rev-parse", ref, "--"] - [sha] <- gitCmdLines ["-C", gitdir, "rev-list", "-n1", ref] - [time] <- gitCmdLines ["-C", gitdir, "show", "-s", "--format=%cI", ref] - utc <- - -- Git sometimes produces timestamps with Z time zone, which are - -- not valid ZonedTimes. - if 'Z' `T.elem` time - then iso8601ParseM (T.unpack time) - else zonedTimeToUTC <$> iso8601ParseM (T.unpack time) - gm <- memoiseGetManifest getManifest' - pure $ - PkgRevInfo - { pkgGetFiles = getFiles gm, - pkgRevCommit = sha, - pkgRevGetManifest = gm, - pkgRevTime = utc - } + sha_out <- gitCmdLines ["-C", gitdir, "rev-list", "-n1", ref] + time_out <- gitCmdLines ["-C", gitdir, "show", "-s", "--format=%cI", ref] + case (sha_out, time_out) of + ([sha], [time]) -> do + utc <- + -- Git sometimes produces timestamps with Z time zone, which are + -- not valid ZonedTimes. + if 'Z' `T.elem` time + then iso8601ParseM (T.unpack time) + else zonedTimeToUTC <$> iso8601ParseM (T.unpack time) + gm <- memoiseGetManifest getManifest' + pure . Just $ + PkgRevInfo + { pkgGetFiles = getFiles gm, + pkgRevCommit = sha, + pkgRevGetManifest = gm, + pkgRevTime = utc + } + _ -> do + logMsg $ "Invalid repository state for " <> path <> "-" <> T.pack ref + pure Nothing where noPkgDir pdir = fail $ @@ -235,7 +240,7 @@ gitdir <- ensureGit cachedir url versions <- mapMaybe isVersionRef <$> gitCmdLines ["-C", gitdir, "tag"] versions' <- - M.fromList . zip versions + M.fromList . mapMaybe sequenceA . zip versions <$> mapM (revInfo gitdir path . versionRef) versions pure $ PkgInfo versions' $ lookupCommit gitdir where @@ -247,7 +252,10 @@ Just v | otherwise = Nothing - lookupCommit gitdir = revInfo gitdir path . maybe "HEAD" T.unpack + lookupCommit gitdir = + maybe (fail $ "Cannot obtain HEAD info for " <> T.unpack path) pure + <=< revInfo gitdir path + . maybe "HEAD" T.unpack -- | A package registry is a mapping from package paths to information -- about the package. It is unlikely that any given registry is diff --git a/src/Futhark/Script.hs b/src/Futhark/Script.hs --- a/src/Futhark/Script.hs +++ b/src/Futhark/Script.hs @@ -26,7 +26,6 @@ EvalBuiltin, scriptBuiltin, evalExp, - getScriptValue, getExpValue, getHaskellValue, evalExpToGround, @@ -61,7 +60,7 @@ import Futhark.Util (nubOrd) import Futhark.Util.Pretty hiding (line, sep, space, ()) import Language.Futhark.Core (Name, nameFromText, nameToText) -import Language.Futhark.Tuple (areTupleFields) +import Language.Futhark.Tuple (areTupleFields, tupleFieldNames) import System.FilePath (()) import Text.Megaparsec import Text.Megaparsec.Char (space) @@ -122,6 +121,7 @@ | Const V.Value | Tuple [Exp] | Record [(T.Text, Exp)] + | Project Exp T.Text | StringLit T.Text | Let [VarName] Exp Exp | -- | Server-side variable, *not* Futhark variable (these are @@ -149,6 +149,8 @@ parensIf (i > 0) $ pretty v <+> hsep (map (align . pprPrec 1) args) pprPrec _ (Tuple vs) = parens $ commasep $ map (align . pretty) vs + pprPrec _ (Project e f) = + pprPrec 1 e <> "." <> pretty f pprPrec _ (StringLit s) = pretty $ show s pprPrec _ (Record m) = braces $ align $ commasep $ map field m where @@ -170,12 +172,12 @@ parseExp sep = choice [ pLet, - try $ Call <$> parseFunc <*> many pAtom, + try $ Call <$> pFunc <*> some pAtom, pAtom ] "expression" where - pField = (,) <$> pVarName <*> (pEquals *> parseExp sep) + pField = (,) <$> lVarName <*> (pEquals *> parseExp sep) pEquals = lexeme sep "=" pComma = lexeme sep "," mkTuple [v] = v @@ -192,6 +194,12 @@ pLet ] + pProject e = + choice + [ lexeme sep "." *> (pFieldName >>= pProject . Project e), + pure e + ] + pAtom = choice [ try $ inParens sep (mkTuple <$> (parseExp sep `sepEndBy` pComma)), @@ -199,30 +207,35 @@ inBraces sep (Record <$> (pField `sepEndBy` pComma)), StringLit . T.pack <$> lexeme sep ("\"" *> manyTill charLiteral "\""), Const <$> V.parseValue sep, - Call <$> parseFunc <*> pure [] + Call <$> pFunc <*> pure [] ] + >>= pProject pPat = choice - [ inParens sep $ pVarName `sepEndBy` pComma, - pure <$> pVarName + [ inParens sep $ lVarName `sepEndBy` pComma, + pure <$> lVarName ] - parseFunc = + pFunc = choice - [ FuncBuiltin <$> ("$" *> pVarName), - FuncFut <$> pVarName + [ FuncBuiltin <$> ("$" *> lVarName), + FuncFut <$> lVarName ] reserved = ["let", "in"] - pVarName = lexeme sep . try $ do + lVarName = lexeme sep . try $ do v <- fmap T.pack $ (:) <$> satisfy isAlpha <*> many (satisfy constituent) guard $ v `notElem` reserved pure v where constituent c = isAlphaNum c || c == '\'' || c == '_' + lIntStr = lexeme sep . try . fmap T.pack $ some $ satisfy isDigit + + pFieldName = lVarName <|> lIntStr + -- | Parse a FutharkScript expression with normal whitespace handling. parseExpFromText :: FilePath -> T.Text -> Either T.Text Exp parseExpFromText f s = @@ -479,6 +492,50 @@ <> " argument(s) of types:\n" <> T.intercalate "\n" (map prettyTextOneLine actual) +getField :: + (MonadIO m, MonadError T.Text m) => + ScriptServer -> + T.Text -> + (Name, b) -> + m VarName +getField server from (f, _) = do + to <- newVar server "field" + cmdMaybe $ cmdProject (scriptServer server) to from $ nameToText f + pure to + +unTuple :: + (MonadIO m, MonadError T.Text m) => + ScriptServer -> + ExpValue -> + m [ExpValue] +unTuple _ (V.ValueTuple vs) = pure vs +unTuple server (V.ValueAtom (SValue t (VVar v))) + | Just ts <- isTuple t $ scriptTypes server = + forM (zip tupleFieldNames ts) $ \(k, kt) -> + V.ValueAtom . SValue kt . VVar <$> getField server v (k, kt) +unTuple _ v = pure [v] + +project :: + (MonadIO m, MonadError T.Text m) => + ScriptServer -> + ExpValue -> + T.Text -> + m ExpValue +project _ (V.ValueRecord fs) k = + case M.lookup k fs of + Nothing -> throwError $ "Unknown field: " <> k + Just v -> pure v +project server (V.ValueAtom (SValue t (VVar v))) f + | Just fs <- isRecord t $ scriptTypes server = + case lookup f' fs of + Nothing -> throwError $ "Type " <> t <> " does not have a field " <> f <> "." + Just ft -> + V.ValueAtom . SValue ft . VVar <$> getField server v (f', ft) + where + f' = nameFromText f +project _ _ _ = + throwError "Cannot project from non-record." + -- | Evaluate a FutharkScript expression relative to some running server. evalExp :: forall m. @@ -502,11 +559,6 @@ cmdMaybe $ cmdNew server v t vs pure v - getField from (f, _) = do - to <- newVar' "field" - cmdMaybe $ cmdProject server to from $ nameToText f - pure to - toVar :: ValOrVar -> m VarName toVar (VVar v) = pure v toVar (VVal val) = do @@ -543,18 +595,19 @@ | Just t_fs <- isRecord t types, Just vt_fs <- isRecord vt types, vt_fs == t_fs = - mkRecord t =<< mapM (getField v) vt_fs + mkRecord t =<< mapM (getField sserver v) vt_fs interValToVar _ t (V.ValueAtom (SValue _ (VVal v))) | Just v' <- coerceValue t v = scriptValueToVar $ SValue t $ VVal v' interValToVar bad _ _ = bad letMatch :: [VarName] -> ExpValue -> m VTable - letMatch vs val - | vals <- V.unCompound val, - length vs == length vals = + letMatch vs val = do + vals <- unTuple sserver val + if length vs == length vs + then pure $ M.fromList (zip vs vals) - | otherwise = + else throwError $ "Pat: " <> prettyTextOneLine vs @@ -564,6 +617,9 @@ evalExp' :: VTable -> Exp -> m ExpValue evalExp' _ (ServerVar t v) = pure $ V.ValueAtom $ SValue t $ VVar v + evalExp' vtable (Project e f) = do + e' <- evalExp' vtable e + project sserver e' f evalExp' vtable (Call (FuncBuiltin name) es) = builtin sserver name =<< mapM (evalExp' vtable) es evalExp' vtable (Call (FuncFut name) es) @@ -586,11 +642,11 @@ then do outs <- replicateM (length out_types) $ newVar' "out" void $ cmdEither $ cmdCall server name outs arg_types - pure $ V.mkCompound $ map V.ValueAtom $ zipWith SValue out_types $ map VVar outs + pure . V.mkCompound . map V.ValueAtom $ + zipWith SValue out_types (map VVar outs) else pure . V.ValueAtom . SFun name in_types out_types $ - zipWith SValue in_types $ - map VVar arg_types + zipWith SValue in_types (map VVar arg_types) -- Careful to not require saturated application, but do still -- check for over-saturation. @@ -635,23 +691,40 @@ throwError e (freeNonresultVars =<< evalExp' mempty top_level_e) `catchError` freeVarsOnError --- | Read actual values from the server. Fails for values that have no --- well-defined external representation. -getScriptValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ScriptValue ValOrVar -> m V.Value -getScriptValue server = toGround <=< traverse onLeaf - where - onLeaf (VVar v) = readVar (scriptServer server) v - onLeaf (VVal v) = pure v - toGround (SFun fname _ _ _) = - throwError $ "Function " <> fname <> " not fully applied." - toGround (SValue _ v) = pure v +primArrayType :: TypeName -> Bool +primArrayType s = case fmap T.uncons <$> T.uncons s of + Just ('[', Just (']', s')) -> primArrayType s' + _ -> s `elem` ["i8", "u8", "i16", "u16", "i32", "u32", "i64", "u64", "f16", "f32", "f64", "bool"] -- | Read actual compound values from the server. Fails for values that have no -- well-defined external representation. getExpValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m V.CompoundValue -getExpValue server = traverse (getScriptValue server) +getExpValue _ (V.ValueAtom (SFun fname _ _ _)) = + throwError $ "Function " <> fname <> " not fully applied." +getExpValue server (V.ValueAtom (SValue t (VVar v))) + | Just fs <- isRecord t types = + tupleOrRecord . M.fromList . zip (map fst fs) + <$> mapM (onField v) fs + | not $ primArrayType t = + throwError $ "Type " <> t <> " has no external representation." + | otherwise = + V.ValueAtom <$> readVar (scriptServer server) v + where + types = scriptTypes server + tupleOrRecord m = + maybe (V.ValueRecord $ M.mapKeys nameToText m) V.ValueTuple $ areTupleFields m + + onField from (f, ft) = do + to <- getField server from (f, ft) + getExpValue server $ V.ValueAtom $ SValue ft $ VVar to +getExpValue server (V.ValueTuple vs) = + V.ValueTuple <$> traverse (getExpValue server) vs +getExpValue server (V.ValueRecord fs) = + V.ValueRecord <$> traverse (getExpValue server) fs +getExpValue _ (V.ValueAtom (SValue _ (VVal v))) = pure $ V.ValueAtom v + -- | Retrieve a Haskell value from an 'ExpValue'. This returns 'Just' if the -- 'ExpValue' is an atom with a non-opaque type. getHaskellValue :: (V.GetValue t, MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m (Maybe t) @@ -683,6 +756,7 @@ -- program. varsInExp :: Exp -> S.Set EntryName varsInExp ServerVar {} = mempty +varsInExp (Project e _) = varsInExp e varsInExp (Call (FuncFut v) es) = S.insert v $ foldMap varsInExp es varsInExp (Call (FuncBuiltin _) es) = foldMap varsInExp es varsInExp (Tuple es) = foldMap varsInExp es diff --git a/src/Futhark/Transform/FirstOrderTransform.hs b/src/Futhark/Transform/FirstOrderTransform.hs --- a/src/Futhark/Transform/FirstOrderTransform.hs +++ b/src/Futhark/Transform/FirstOrderTransform.hs @@ -13,6 +13,7 @@ transformStmRecursively, transformLambda, transformSOAC, + transformScrema, ) where @@ -113,19 +114,15 @@ letExp "result" =<< eBlank t mapM oneArray ts --- | Transform a single 'SOAC' into a do-loop. The body of the lambda --- is untouched, and may or may not contain further 'SOAC's depending --- on the given rep. -transformSOAC :: +-- | Sequentialise a single Screma. +transformScrema :: (Transformer m) => - Pat (LetDec (Rep m)) -> - SOAC (Rep m) -> + Pat dec -> + SubExp -> + [VName] -> + ScremaForm (Rep m) -> m () -transformSOAC _ JVP {} = - error "transformSOAC: unhandled JVP" -transformSOAC _ VJP {} = - error "transformSOAC: unhandled VJP" -transformSOAC pat (Screma w arrs form@(ScremaForm map_lam scans reds)) = do +transformScrema pat w arrs form@(ScremaForm map_lam scans reds) = do -- See Note [Translation of Screma]. -- -- Start by combining all the reduction and scan parts into a single @@ -226,6 +223,21 @@ (++ patNames pat) <$> replicateM (length scanacc_params) (newVName "discard") letBindNames names $ Loop merge loopform loop_body + +-- | Transform a single 'SOAC' into a do-loop. The body of the lambda +-- is untouched, and may or may not contain further 'SOAC's depending +-- on the given rep. +transformSOAC :: + (Transformer m) => + Pat (LetDec (Rep m)) -> + SOAC (Rep m) -> + m () +transformSOAC _ JVP {} = + error "transformSOAC: unhandled JVP" +transformSOAC _ VJP {} = + error "transformSOAC: unhandled VJP" +transformSOAC pat (Screma w arrs form) = + transformScrema pat w arrs form transformSOAC pat (Stream w arrs nes lam) = do -- Create a loop that repeatedly applies the lambda body to a -- chunksize of 1. Hopefully this will lead to this outer loop diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -91,7 +91,7 @@ import System.FilePath qualified as Native import System.FilePath.Posix qualified as Posix import System.IO (Handle, hIsTerminalDevice, stdout) -import System.IO.Error (isDoesNotExistError) +import System.IO.Error (isAlreadyInUseError, isDoesNotExistError) import System.IO.Unsafe import System.Process.ByteString import Text.Read (readMaybe) @@ -534,9 +534,15 @@ ensureCacheDirectory fpath = do createDirectoryIfMissing True fpath l <- listDirectory fpath - when (null l) . T.writeFile (fpath "CACHEDIR.TAG") . T.unlines $ + when (null l) . okIfInUse . T.writeFile (fpath "CACHEDIR.TAG") . T.unlines $ [ "Signature: 8a477f597d28d172789f06886806bc55", "# This file is a cache directory tag created by futhark.", "# For information about cache directory tags, see:", "# https://bford.info/cachedir/" ] + where + -- Several threads may be trying to create this file concurrently, which + -- will normally result in an exception due to locking - but it is actually + -- fine. They will all be trying to write the same thing anyway. + okIfInUse m = + catchJust (guard . isAlreadyInUseError) m (const $ pure ()) 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 @@ -78,7 +78,7 @@ data BreakReason = -- | An explicit breakpoint in the program. BreakPoint - | -- | A + | -- | An arithmetic operation produced a fresh NaN. BreakNaN data ExtOp a @@ -225,7 +225,7 @@ match _ _ _ = pure mempty matchDims bound e1 (SizeClosure env e2) - | e1 == anySize || e2 == anySize = pure mempty + | isJust (isAnySize e1) || isJust (isAnySize e2) = pure mempty | otherwise = matchExps bound env e1 e2 matchExps bound env (Var (QualName _ d1) _ _) e @@ -252,8 +252,8 @@ ds' <- mapM (traverse $ \(SizeClosure env e) -> asInt64 <$> evalWithExts env e) ds pure $ typeEnv (M.fromList ts') <> i64Env (M.fromList ds') where - onDim (Left x) = sizeFromInteger (toInteger x) mempty - onDim (Right (SizeClosure _ e)) = e -- FIXME + onDim (Left x) = SizeClosure mempty $ sizeFromInteger (toInteger x) mempty + onDim (Right e) = e resolveExistentials :: [VName] -> StructType -> ValueShape -> M.Map VName Int64 resolveExistentials names = match @@ -348,9 +348,8 @@ -- an existential. data TermBinding = TermValue (Maybe T.BoundV) Value - | -- | A polymorphic value that must be instantiated. The - -- 'StructType' provided is un-evaluated, but parts of it can be - -- evaluated using the provided 'Eval' function. + | -- | A polymorphic value that must be instantiated. The 'EvalType' provided + -- is the type of the instantiation. TermPoly (Maybe T.BoundV) (EvalType -> EvalM Value) | TermModule Module @@ -359,7 +358,13 @@ show (TermPoly bv _) = unwords ["TermPoly", show bv] show (TermModule m) = unwords ["TermModule", show m] -data TypeBinding = TypeBinding Env [TypeParam] StructRetType +data TypeBinding + = TypeConBinding + Env + [TypeParam] + (RetTypeBase Size NoUniqueness) + | TypeBinding + EvalType deriving (Show) data Module @@ -406,14 +411,12 @@ envType = mempty } -typeEnv :: M.Map VName StructType -> Env +typeEnv :: M.Map VName EvalType -> Env typeEnv m = Env { envTerm = mempty, - envType = M.map tbind m + envType = M.map TypeBinding m } - where - tbind = TypeBinding mempty [] . RetType [] i64Env :: M.Map VName Int64 -> Env i64Env = valEnv . M.map f @@ -665,14 +668,16 @@ in second (const u) (arrayOf shape' $ toStruct et') expandType env (Scalar (TypeVar u tn args)) = case lookupType tn env of - Just (TypeBinding tn_env ps (RetType ext t')) -> + Just (TypeBinding t') -> + second (const u) t' + Just (TypeConBinding tn_env ps (RetType ext t')) -> let (substs, types) = mconcat $ zipWith matchPtoA ps args onDim (SizeClosure dim_env dim) | any (`elem` ext) $ fvVars $ freeInExp dim = - -- The case can occur when a type with existential - -- size has been hidden by a module ascription, e.g. + -- The case can occur when a type with existential size has been + -- hidden by a module ascription, e.g. -- tests/modules/sizeparams4.fut. - SizeClosure mempty anySize + SizeClosure mempty $ anySize 0 | otherwise = SizeClosure (env <> dim_env) $ applySubst (`M.lookup` substs) dim @@ -685,8 +690,8 @@ matchPtoA (TypeParamDim p _) (TypeArgDim e) = (M.singleton p $ ExpSubst e, mempty) matchPtoA (TypeParamType _ p _) (TypeArgType t') = - let t'' = evalToStruct $ expandType env t' -- FIXME, we are throwing away the closure here. - in (mempty, M.singleton p (TypeBinding mempty [] $ RetType [] t'')) + let t'' = expandType env t' + in (mempty, M.singleton p (TypeBinding t'')) matchPtoA _ _ = mempty expandArg (TypeArgDim s) = TypeArgDim $ SizeClosure env s expandArg (TypeArgType t) = TypeArgType $ expandType env t @@ -1139,7 +1144,7 @@ k' <- replace k pure (k', f v) onEnv (Env terms types) = - Env (replaceM onTerm terms) (replaceM onType types) + Env (replaceM onTerm terms) (replaceM id types) onModule (Module env) = Module $ onEnv env onModule (ModuleFun f) = @@ -1147,7 +1152,6 @@ onTerm (TermValue t v) = TermValue t v onTerm (TermPoly t v) = TermPoly t v onTerm (TermModule m) = TermModule $ onModule m - onType (TypeBinding env ps t) = TypeBinding (onEnv env) ps t evalModuleVar :: Env -> QualName VName -> EvalM Module evalModuleVar env qv = @@ -1228,7 +1232,7 @@ evalDec env (LocalDec d _) = evalDec env d evalDec _env ModTypeDec {} = pure mempty evalDec env (TypeDec (TypeBind v _ ps _ (Info (RetType dims t)) _ _)) = do - let abbr = TypeBinding env ps $ RetType dims t + let abbr = TypeConBinding env ps $ RetType dims t pure mempty {envType = M.singleton v abbr} evalDec env (ModDec (ModBind v ps ret body _ loc)) = do (mod_env, mod) <- evalModExp env $ wrapInLambda ps @@ -2143,7 +2147,7 @@ tdef :: Name -> Maybe TypeBinding tdef s = do t <- s `M.lookup` namesToPrimTypes - pure $ TypeBinding mempty [] $ RetType [] $ Scalar $ Prim t + pure $ TypeConBinding mempty [] $ RetType [] $ Scalar $ Prim t intrinsicVal :: Name -> Value intrinsicVal name = 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 @@ -48,7 +48,7 @@ instance IsName VName where prettyName | isEnvVarAtLeast "FUTHARK_COMPILER_DEBUGGING" 1 = - \(VName vn i) -> pretty vn <> "_" <> pretty (show i) + \(VName vn i) -> pretty vn <> "_" <> pretty i | otherwise = pretty . baseName toName = baseName 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 @@ -22,6 +22,7 @@ defaultEntryPoint, paramName, anySize, + isAnySize, -- * Queries on expressions typeOf, @@ -357,19 +358,24 @@ paramName (Named v) = Just v paramName Unnamed = Nothing --- | A special expression representing no known size. When present in --- a type, each instance represents a distinct size. The type checker --- should _never_ produce these - they are a (hopefully temporary) --- thing introduced by defunctorisation and monomorphisation. They --- represent a flaw in our implementation. When they occur in a --- return type, they can be replaced with freshly created existential --- sizes. When they occur in parameter types, they can be replaced --- with size parameters. -anySize :: Size -anySize = - -- The definition here is weird to avoid seeing this as a free - -- variable. - StringLit [65, 78, 89] mempty +-- | A special expression representing no known size, but encoding an +-- equivalence class (represented by the integer) that can be used to detect +-- unknown-but-equal sizes. This is important so that we do not throw away size +-- equalities just because the names become unknown to us (e.g. see #2326). The +-- type checker should _never_ produce anySizes - they are a (hopefully +-- temporary) thing introduced by defunctorisation and monomorphisation. They +-- represent a flaw in our implementation. When they occur in a return type, +-- they can be replaced with freshly created existential sizes. When they occur +-- in parameter types, they can be replaced with size parameters. +anySize :: Int -> Size +anySize x = + -- The definition here is weird to avoid seeing this as a free variable. + StringLit (map (fromIntegral . ord) (show x)) mempty + +-- | If this is any size, retrieve the key for the equivalence class. +isAnySize :: Size -> Maybe Int +isAnySize (StringLit xs _) = Just $ read $ map (chr . fromIntegral) xs +isAnySize _ = Nothing -- | Match the dimensions of otherwise assumed-equal types. The -- combining function is also passed the names bound within the type diff --git a/src/Language/Futhark/TypeChecker/Consumption.hs b/src/Language/Futhark/TypeChecker/Consumption.hs --- a/src/Language/Futhark/TypeChecker/Consumption.hs +++ b/src/Language/Futhark/TypeChecker/Consumption.hs @@ -2,6 +2,12 @@ -- constraints. module Language.Futhark.TypeChecker.Consumption ( checkValDef, + + -- * For testing + Alias (..), + Aliases, + TypeAliases, + inferReturnUniqueness, ) where @@ -414,6 +420,10 @@ where delve (Scalar (Record fs)) = foldl' (M.unionWith (+)) mempty $ map delve $ M.elems fs + delve (Scalar (TypeVar als _ _)) = + -- We cannot know anything about abstract types, but must conservatively + -- assume the worst. + M.fromList $ map ((,2 :: Int) . aliasVar) $ S.toList als delve t = M.fromList $ map ((,1 :: Int) . aliasVar) $ S.toList $ aliases t @@ -1012,7 +1022,10 @@ addError retdecl' mempty "A top-level constant cannot have a unique type." pure $ RetType ext ret Nothing -> - pure $ RetType ext $ inferReturnUniqueness params ret body_als + pure $ + RetType ext $ + inferReturnUniqueness params ret body_als + pure ( (body', ret'), body_als -- Don't matter. diff --git a/src/Language/Futhark/TypeChecker/Terms/Pat.hs b/src/Language/Futhark/TypeChecker/Terms/Pat.hs --- a/src/Language/Futhark/TypeChecker/Terms/Pat.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Pat.hs @@ -26,12 +26,12 @@ nonrigidFor :: [(SizeBinder VName, QualName VName)] -> StructType -> StructType nonrigidFor [] = id -- Minor optimisation. -nonrigidFor sizes = first onDim +nonrigidFor sizes = applySubst onDim where - onDim (Var (QualName _ v) info loc) - | Just (_, v') <- find ((== v) . sizeName . fst) sizes = - Var v' info loc - onDim d = d + onDim v + | Just (s, v') <- find ((== v) . sizeName . fst) sizes = + Just $ ExpSubst $ sizeFromName v' (srclocOf s) + onDim _ = Nothing -- | Bind these identifiers locally while running the provided action. binding :: diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -533,7 +533,9 @@ -- AnySize. This should _never_ happen during type-checking, but -- may happen as we substitute types during monomorphisation and -- defunctorisation later on. See Note [AnySize] - let toAny (Var v _ _) | qualLeaf v `elem` dims = anySize + let toAny (Var v _ _) + | qualLeaf v `elem` dims = + anySize (baseTag (qualLeaf v)) toAny d = d in first toAny ot'