futhark 0.25.33 → 0.25.34
raw patch · 45 files changed
+820/−492 lines, 45 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Futhark.SyntaxTests: instance Data.String.IsString Language.Futhark.Syntax.ParamType
+ Language.Futhark.SyntaxTests: instance Data.String.IsString Language.Futhark.Syntax.ResType
+ Language.Futhark.TypeChecker.ConsumptionTests: tests :: TestTree
Files
- CHANGELOG.md +32/−0
- docs/language-reference.rst +1/−1
- docs/man/futhark-literate.rst +11/−10
- futhark.cabal +2/−1
- rts/c/backends/cuda.h +7/−1
- src-testing/Language/Futhark/SyntaxTests.hs +12/−1
- src-testing/Language/Futhark/TypeChecker/ConsumptionTests.hs +63/−0
- src-testing/Language/Futhark/TypeCheckerTests.hs +3/−1
- src/Futhark/Analysis/SymbolTable.hs +12/−17
- src/Futhark/CLI/Dev.hs +13/−10
- src/Futhark/CLI/Literate.hs +2/−1
- src/Futhark/CodeGen/Backends/GenericC/Monad.hs +7/−2
- src/Futhark/CodeGen/ImpGen/Multicore.hs +3/−3
- src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs +12/−14
- src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs +5/−5
- src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs +43/−45
- src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs +28/−30
- src/Futhark/IR/Mem/Simplify.hs +1/−1
- src/Futhark/IR/Prop/Scope.hs +15/−4
- src/Futhark/IR/SOACS/Simplify.hs +13/−11
- src/Futhark/IR/SegOp.hs +7/−11
- src/Futhark/Internalise.hs +1/−1
- src/Futhark/Internalise/Defunctionalise.hs +78/−75
- src/Futhark/Internalise/Entry.hs +1/−1
- src/Futhark/Internalise/Exps.hs +3/−9
- src/Futhark/Internalise/FullNormalise.hs +6/−2
- src/Futhark/Internalise/Monomorphise.hs +150/−97
- src/Futhark/Internalise/TypesValues.hs +1/−1
- src/Futhark/Optimise/InliningDeadFun.hs +1/−1
- src/Futhark/Optimise/Simplify.hs +7/−7
- src/Futhark/Optimise/Simplify/Engine.hs +2/−2
- src/Futhark/Optimise/Simplify/Rules.hs +30/−10
- src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +1/−1
- src/Futhark/Optimise/Simplify/Rules/Index.hs +6/−0
- src/Futhark/Optimise/Sink.hs +5/−5
- src/Futhark/Pkg/Info.hs +28/−20
- src/Futhark/Script.hs +109/−35
- src/Futhark/Transform/FirstOrderTransform.hs +23/−11
- src/Futhark/Util.hs +8/−2
- src/Language/Futhark/Interpreter.hs +26/−22
- src/Language/Futhark/Pretty.hs +1/−1
- src/Language/Futhark/Prop.hs +19/−13
- src/Language/Futhark/TypeChecker/Consumption.hs +14/−1
- src/Language/Futhark/TypeChecker/Terms/Pat.hs +5/−5
- src/Language/Futhark/TypeChecker/Types.hs +3/−1
CHANGELOG.md view
@@ -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
docs/language-reference.rst view
@@ -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.
docs/man/futhark-literate.rst view
@@ -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"
futhark.cabal view
@@ -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
rts/c/backends/cuda.h view
@@ -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);
src-testing/Language/Futhark/SyntaxTests.hs view
@@ -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
+ src-testing/Language/Futhark/TypeChecker/ConsumptionTests.hs view
@@ -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)+ ]+ ]
src-testing/Language/Futhark/TypeCheckerTests.hs view
@@ -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 ]
src/Futhark/Analysis/SymbolTable.hs view
@@ -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 =
src/Futhark/CLI/Dev.hs view
@@ -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
src/Futhark/CLI/Literate.hs view
@@ -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'.
src/Futhark/CodeGen/Backends/GenericC/Monad.hs view
@@ -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
src/Futhark/CodeGen/ImpGen/Multicore.hs view
@@ -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 =
src/Futhark/CodeGen/ImpGen/Multicore/SegHist.hs view
@@ -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 ->
src/Futhark/CodeGen/ImpGen/Multicore/SegMap.hs view
@@ -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
src/Futhark/CodeGen/ImpGen/Multicore/SegRed.hs view
@@ -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' []
src/Futhark/CodeGen/ImpGen/Multicore/SegScan.hs view
@@ -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 ->
src/Futhark/IR/Mem/Simplify.hs view
@@ -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
src/Futhark/IR/Prop/Scope.hs view
@@ -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
src/Futhark/IR/SOACS/Simplify.hs view
@@ -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
src/Futhark/IR/SegOp.hs view
@@ -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.
src/Futhark/Internalise.hs view
@@ -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"
src/Futhark/Internalise/Defunctionalise.hs view
@@ -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 #-}
src/Futhark/Internalise/Entry.hs view
@@ -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 ->
src/Futhark/Internalise/Exps.hs view
@@ -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', "]"]
src/Futhark/Internalise/FullNormalise.hs view
@@ -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}
src/Futhark/Internalise/Monomorphise.hs view
@@ -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+ )
src/Futhark/Internalise/TypesValues.hs view
@@ -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
src/Futhark/Optimise/InliningDeadFun.hs view
@@ -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
src/Futhark/Optimise/Simplify.hs view
@@ -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
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -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 ->
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -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)
src/Futhark/Optimise/Simplify/Rules/BasicOp.hs view
@@ -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
src/Futhark/Optimise/Simplify/Rules/Index.hs view
@@ -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 [] ->
src/Futhark/Optimise/Sink.hs view
@@ -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
src/Futhark/Pkg/Info.hs view
@@ -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
src/Futhark/Script.hs view
@@ -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
src/Futhark/Transform/FirstOrderTransform.hs view
@@ -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
src/Futhark/Util.hs view
@@ -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 ())
src/Language/Futhark/Interpreter.hs view
@@ -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 =
src/Language/Futhark/Pretty.hs view
@@ -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
src/Language/Futhark/Prop.hs view
@@ -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
src/Language/Futhark/TypeChecker/Consumption.hs view
@@ -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.
src/Language/Futhark/TypeChecker/Terms/Pat.hs view
@@ -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 ::
src/Language/Futhark/TypeChecker/Types.hs view
@@ -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'