futhark 0.25.27 → 0.25.28
raw patch · 32 files changed
+309/−248 lines, 32 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Language.Futhark.Interpreter: instance GHC.Show.Show Language.Futhark.Interpreter.TypeBinding
- Futhark.IR.SegOp: SegHist :: lvl -> SegSpace -> [HistOp rep] -> [Type] -> KernelBody rep -> SegOp lvl rep
+ Futhark.IR.SegOp: SegHist :: lvl -> SegSpace -> [Type] -> KernelBody rep -> [HistOp rep] -> SegOp lvl rep
- Futhark.IR.SegOp: SegRed :: lvl -> SegSpace -> [SegBinOp rep] -> [Type] -> KernelBody rep -> SegOp lvl rep
+ Futhark.IR.SegOp: SegRed :: lvl -> SegSpace -> [Type] -> KernelBody rep -> [SegBinOp rep] -> SegOp lvl rep
- Futhark.IR.SegOp: SegScan :: lvl -> SegSpace -> [SegBinOp rep] -> [Type] -> KernelBody rep -> SegOp lvl rep
+ Futhark.IR.SegOp: SegScan :: lvl -> SegSpace -> [Type] -> KernelBody rep -> [SegBinOp rep] -> SegOp lvl rep
Files
- CHANGELOG.md +21/−0
- docs/man/futhark-test.rst +2/−2
- futhark.cabal +1/−1
- rts/c/timing.h +6/−7
- src/Futhark/Analysis/Interference.hs +3/−3
- src/Futhark/Analysis/LastUse.hs +3/−3
- src/Futhark/Analysis/MemAlias.hs +3/−3
- src/Futhark/CLI/Main.hs +3/−0
- src/Futhark/CLI/Test.hs +2/−2
- src/Futhark/CodeGen/ImpGen/GPU.hs +3/−3
- src/Futhark/CodeGen/ImpGen/GPU/Block.hs +3/−3
- src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs +28/−22
- src/Futhark/CodeGen/ImpGen/Multicore.hs +3/−3
- src/Futhark/IR/Parse.hs +5/−12
- src/Futhark/IR/SegOp.hs +60/−63
- src/Futhark/Internalise/Exps.hs +9/−1
- src/Futhark/Internalise/Monomorphise.hs +20/−8
- src/Futhark/Optimise/ArrayShortCircuiting.hs +6/−6
- src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs +3/−3
- src/Futhark/Optimise/HistAccs.hs +1/−1
- src/Futhark/Optimise/MemoryBlockMerging.hs +33/−27
- src/Futhark/Optimise/ReduceDeviceSyncs.hs +9/−6
- src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs +3/−3
- src/Futhark/Pass/ExpandAllocations.hs +6/−6
- src/Futhark/Pass/ExplicitAllocations/GPU.hs +1/−1
- src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +3/−3
- src/Futhark/Pass/ExtractKernels/DistributeNests.hs +13/−9
- src/Futhark/Pass/ExtractKernels/Intrablock.hs +13/−4
- src/Futhark/Pass/ExtractMulticore.hs +3/−3
- src/Futhark/Pass/LiftAllocations.hs +6/−6
- src/Futhark/Pass/LowerAllocations.hs +6/−6
- src/Language/Futhark/Interpreter.hs +28/−28
CHANGELOG.md view
@@ -5,6 +5,27 @@ 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.28]++### Added++### Removed++### Changed++### Fixed++* Compiler crash for intrablock scatters that write to+ multidimensional arrays. (#2218)++* Handling of size expressions in abstract types in the interpreter (#2222).++* GPU code generation of segmented reductions with array operands. (#2227)++* Server-mode timing is now done with a monotonic clock.++* `futhark test` now respects `notest`, similar to `nobench` for `futhark bench`.+ ## [0.25.27] ### Added
docs/man/futhark-test.rst view
@@ -151,8 +151,8 @@ --exclude=tag Do not run test cases that contain the given tag. Cases marked with- "disable" are ignored by default, as are cases marked "no_foo",- where *foo* is the backend used.+ "notest", "disable", or "no_foo" (where *foo* is the backend used)+ are ignored by default. -i Test with the interpreter.
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark-version: 0.25.27+version: 0.25.28 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to
rts/c/timing.h view
@@ -24,17 +24,16 @@ #include <time.h> #include <sys/time.h> -static int64_t get_wall_time(void) {- struct timeval time;- assert(gettimeofday(&time,NULL) == 0);- return time.tv_sec * 1000000 + time.tv_usec;-}- static int64_t get_wall_time_ns(void) { struct timespec time;- assert(clock_gettime(CLOCK_REALTIME, &time) == 0);+ assert(clock_gettime(CLOCK_MONOTONIC, &time) == 0); return time.tv_sec * 1000000000 + time.tv_nsec; }++static int64_t get_wall_time(void) {+ return get_wall_time_ns() / 1000;+}+ #endif
src/Futhark/Analysis/Interference.hs view
@@ -159,11 +159,11 @@ m (InUse, LastUsed, Graph VName) analyseSegOp lumap inuse (SegMap _ _ _ body) = analyseKernelBody lumap inuse body-analyseSegOp lumap inuse (SegRed _ _ binops _ body) =+analyseSegOp lumap inuse (SegRed _ _ _ body binops) = segWithBinOps lumap inuse binops body-analyseSegOp lumap inuse (SegScan _ _ binops _ body) = do+analyseSegOp lumap inuse (SegScan _ _ _ body binops) = do segWithBinOps lumap inuse binops body-analyseSegOp lumap inuse (SegHist _ _ histops _ body) = do+analyseSegOp lumap inuse (SegHist _ _ _ body histops) = do (inuse', lus', graph) <- analyseKernelBody lumap inuse body (inuse'', lus'', graph') <- mconcat <$> mapM (analyseHistOp lumap inuse') histops pure (inuse'', lus' <> lus'', graph <> graph')
src/Futhark/Analysis/LastUse.hs view
@@ -312,17 +312,17 @@ (used_nms', lu_vars) <- lastUsedInNames used_nms $ freeIn tps (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') pure (body_lutab, lu_vars, used_nms' <> used_nms'')-lastUseSegOp (SegRed _ _ sbos tps kbody) used_nms = do+lastUseSegOp (SegRed _ _ tps kbody sbos) used_nms = do (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseSegBinOp sbos used_nms (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'')-lastUseSegOp (SegScan _ _ sbos tps kbody) used_nms = do+lastUseSegOp (SegScan _ _ tps kbody sbos) used_nms = do (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseSegBinOp sbos used_nms (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms') pure (M.union lutab_sbo body_lutab, lu_vars <> lu_vars_sbo, used_nms_sbo <> used_nms' <> used_nms'')-lastUseSegOp (SegHist _ _ hos tps kbody) used_nms = do+lastUseSegOp (SegHist _ _ tps kbody hos) used_nms = do (lutab_sbo, lu_vars_sbo, used_nms_sbo) <- lastUseHistOp hos used_nms (used_nms', lu_vars) <- lastUsedInNames used_nms_sbo $ freeIn tps (body_lutab, used_nms'') <- lastUseKernelBody kbody (mempty, used_nms')
src/Futhark/Analysis/MemAlias.hs view
@@ -68,11 +68,11 @@ analyzeHostOp :: MemAliases -> HostOp NoOp GPUMem -> MemAliasesM (HostOp NoOp GPUMem) MemAliases analyzeHostOp m (SegOp (SegMap _ _ _ kbody)) = analyzeStms (kernelBodyStms kbody) m-analyzeHostOp m (SegOp (SegRed _ _ _ _ kbody)) =+analyzeHostOp m (SegOp (SegRed _ _ _ kbody _)) = analyzeStms (kernelBodyStms kbody) m-analyzeHostOp m (SegOp (SegScan _ _ _ _ kbody)) =+analyzeHostOp m (SegOp (SegScan _ _ _ kbody _)) = analyzeStms (kernelBodyStms kbody) m-analyzeHostOp m (SegOp (SegHist _ _ _ _ kbody)) =+analyzeHostOp m (SegOp (SegHist _ _ _ kbody _)) = analyzeStms (kernelBodyStms kbody) m analyzeHostOp m SizeOp {} = pure m analyzeHostOp m GPUBody {} = pure m
src/Futhark/CLI/Main.hs view
@@ -3,6 +3,7 @@ import Control.Exception import Data.List (sortOn)+import Data.List qualified as L import Data.Maybe import Data.Text.IO qualified as T import Futhark.CLI.Autotune qualified as Autotune@@ -154,4 +155,6 @@ case args of cmd : args' | Just (m, _) <- lookup cmd commands -> m (unwords [prog, cmd]) args'+ | not $ "-" `L.isPrefixOf` cmd ->+ optionsError $ "unknown subcommand \"" <> cmd <> "\"." _ -> mainWithOptions () [] msg (const . const Nothing) prog args
src/Futhark/CLI/Test.hs view
@@ -460,7 +460,7 @@ makeTestCase :: TestConfig -> TestMode -> (FilePath, ProgramTest) -> TestCase makeTestCase config mode (file, spec) =- TestCase mode file spec $ configPrograms config+ excludeCases config $ TestCase mode file spec $ configPrograms config data ReportMsg = TestStarted TestCase@@ -677,7 +677,7 @@ defaultConfig = TestConfig { configTestMode = Compiled,- configExclude = ["disable"],+ configExclude = ["disable", "notest"], configPrograms = ProgConfig { configBackend = "c",
src/Futhark/CodeGen/ImpGen/GPU.hs view
@@ -153,11 +153,11 @@ CallKernelGen () segOpCompiler pat (SegMap lvl space _ kbody) = compileSegMap pat lvl space kbody-segOpCompiler pat (SegRed lvl@(SegThread _ _) space reds _ kbody) =+segOpCompiler pat (SegRed lvl@(SegThread _ _) space _ kbody reds) = compileSegRed pat lvl space reds kbody-segOpCompiler pat (SegScan lvl@(SegThread _ _) space scans _ kbody) =+segOpCompiler pat (SegScan lvl@(SegThread _ _) space _ kbody scans) = compileSegScan pat lvl space scans kbody-segOpCompiler pat (SegHist lvl@(SegThread _ _) space ops _ kbody) =+segOpCompiler pat (SegHist lvl@(SegThread _ _) space _ kbody ops) = compileSegHist pat lvl space ops kbody segOpCompiler pat segop = compilerBugS $ "segOpCompiler: unexpected " ++ prettyString (segLevel segop) ++ " for rhs of pattern " ++ prettyString pat
src/Futhark/CodeGen/ImpGen/GPU/Block.hs view
@@ -365,7 +365,7 @@ zipWithM_ (compileThreadResult space) (patElems pat) $ kernelBodyResult body sOp $ Imp.ErrorSync Imp.FenceLocal-compileBlockOp pat (Inner (SegOp (SegScan lvl space scans _ body))) = do+compileBlockOp pat (Inner (SegOp (SegScan lvl space _ body scans))) = do compileFlatId space let (ltids, dims) = unzip $ unSegSpace space@@ -412,7 +412,7 @@ (product dims') (segBinOpLambda scan) arrs_flat-compileBlockOp pat (Inner (SegOp (SegRed lvl space ops _ body))) = do+compileBlockOp pat (Inner (SegOp (SegRed lvl space _ body ops))) = do compileFlatId space let dims' = map pe64 dims@@ -533,7 +533,7 @@ (map (unitSlice 0) (init dims') ++ [DimFix $ last dims' - 1]) sOp $ Imp.Barrier Imp.FenceLocal-compileBlockOp pat (Inner (SegOp (SegHist lvl space ops _ kbody))) = do+compileBlockOp pat (Inner (SegOp (SegHist lvl space _ kbody ops))) = do compileFlatId space let (ltids, dims) = unzip $ unSegSpace space
src/Futhark/CodeGen/ImpGen/GPU/SegRed.hs view
@@ -143,7 +143,12 @@ compileSegRed' pat grid space segbinops map_body_cont | genericLength segbinops > maxNumOps = compilerLimitationS $- ("compileSegRed': at most " <> show maxNumOps <> " reduction operators are supported.\n")+ ( "compileSegRed': at most "+ <> show maxNumOps+ <> " reduction operators are supported,\nbut found kernel with "+ <> show (length segbinops)+ <> ".\n"+ ) <> ("Pattern: " <> prettyString pat) | otherwise = do chunk_v <- dPrimV "chunk_size" . isInt64 =<< kernelConstToExp chunk_const@@ -192,7 +197,7 @@ all isPrimSegBinOp segbinops = noncommPrimSegRedInterms | otherwise =- generalSegRedInterms tblock_id tblock_size segbinops+ generalSegRedInterms False tblock_id tblock_size segbinops where params = map paramOf segbinops @@ -246,24 +251,28 @@ forAccumLM2D acc ls f = mapAccumLM (mapAccumLM f) acc ls generalSegRedInterms ::+ Bool -> Imp.TExp Int64 -> SubExp -> [SegBinOp GPUMem] -> InKernelGen [SegRedIntermediateArrays]-generalSegRedInterms tblock_id tblock_size segbinops =- fmap (map GeneralSegRedInterms) $- forM (map paramOf segbinops) $- mapM $ \p ->- case paramDec p of- MemArray pt shape _ (ArrayIn mem _) -> do- let shape' = Shape [tblock_size] <> shape- let shape_E = map pe64 $ shapeDims shape'- sArray ("red_arr_" ++ prettyString pt) pt shape' mem $- LMAD.iota (tblock_id * product shape_E) shape_E- _ -> do- let pt = elemType $ paramType p- shape = Shape [tblock_size]- sAllocArray ("red_arr_" ++ prettyString pt) pt shape $ Space "shared"+generalSegRedInterms segmented tblock_id tblock_size segbinops =+ fmap (map GeneralSegRedInterms) . forM (map paramOf segbinops) . mapM $ \p ->+ case paramDec p of+ MemArray pt shape _ (ArrayIn mem ixfun) -> do+ let shape' = Shape [tblock_size] <> shape+ let shape_E = map pe64 $ shapeDims shape'+ sArray ("red_arr_" ++ prettyString pt) pt shape' mem $+ -- This 'segmented' thing here is a hack, related to #2227.+ -- There absolutely must be some unifying principle we are+ -- missing.+ if segmented+ then ixfun+ else LMAD.iota (tblock_id * product shape_E) shape_E+ _ -> do+ let pt = elemType $ paramType p+ shape = Shape [tblock_size]+ sAllocArray ("red_arr_" ++ prettyString pt) pt shape $ Space "shared" -- | Arrays for storing block results. --@@ -380,7 +389,7 @@ dPrimVE "segment_size_nonzero" $ sMax64 1 segment_size let tblock_size_se = unCount tblock_size- num_tblocks_se = unCount tblock_size+ num_tblocks_se = unCount num_tblocks num_tblocks' = pe64 num_tblocks_se tblock_size' = pe64 tblock_size_se num_threads <- fmap tvSize $ dPrimV "num_threads" $ num_tblocks' * tblock_size'@@ -399,7 +408,7 @@ let tblock_id = kernelBlockSize constants ltid = sExt64 $ kernelLocalThreadId constants - interms <- generalSegRedInterms tblock_id tblock_size_se segbinops+ interms <- generalSegRedInterms True tblock_id tblock_size_se segbinops let reds_arrs = map blockRedArrs interms -- We probably do not have enough actual threadblocks to cover the@@ -921,10 +930,7 @@ block_res_arrs = blockResArrs slug old_counter <- dPrim "old_counter"- (counter_mem, _, counter_offset) <-- fullyIndexArray- counters- [counter_idx]+ (counter_mem, _, counter_offset) <- fullyIndexArray counters [counter_idx] sComment "first thread in block saves block result to global memory" $ sWhen (ltid32 .==. 0) $ do forM_ (take (length nes) $ zip block_res_arrs (slugAccs slug)) $ \(v, (acc, acc_is)) ->
src/Futhark/CodeGen/ImpGen/Multicore.hs view
@@ -164,11 +164,11 @@ SegOp () MCMem -> TV Int32 -> ImpM MCMem HostEnv Imp.Multicore Imp.MCCode-compileSegOp pat (SegHist _ space histops _ kbody) ntasks =+compileSegOp pat (SegHist _ space _ kbody histops) ntasks = compileSegHist pat space histops kbody ntasks-compileSegOp pat (SegScan _ space scans _ kbody) ntasks =+compileSegOp pat (SegScan _ space _ kbody scans) ntasks = compileSegScan pat space scans kbody ntasks-compileSegOp pat (SegRed _ space reds _ kbody) ntasks =+compileSegOp pat (SegRed _ space _ kbody reds) ntasks = compileSegRed pat space reds kbody ntasks compileSegOp pat (SegMap _ space _ kbody) _ = compileSegMap pat space kbody
src/Futhark/IR/Parse.hs view
@@ -919,18 +919,10 @@ keyword "seghist" *> pSegHist ] where- pSegMap =- SegOp.SegMap- <$> pLvl- <*> pSegSpace- <* pColon- <*> pTypes- <*> braces (pKernelBody pr)- pSegOp' f p =+ pSegOp' f = f <$> pLvl <*> pSegSpace- <*> parens (p `sepBy` pComma) <* pColon <*> pTypes <*> braces (pKernelBody pr)@@ -953,9 +945,10 @@ <*> pShape <* pComma <*> pLambda pr- pSegRed = pSegOp' SegOp.SegRed pSegBinOp- pSegScan = pSegOp' SegOp.SegScan pSegBinOp- pSegHist = pSegOp' SegOp.SegHist pHistOp+ pSegMap = pSegOp' SegOp.SegMap+ pSegRed = pSegOp' SegOp.SegRed <*> parens (pSegBinOp `sepBy` pComma)+ pSegScan = pSegOp' SegOp.SegScan <*> parens (pSegBinOp `sepBy` pComma)+ pSegHist = pSegOp' SegOp.SegHist <*> parens (pHistOp `sepBy` pComma) pSegLevel :: Parser GPU.SegLevel pSegLevel =
src/Futhark/IR/SegOp.hs view
@@ -450,9 +450,9 @@ = SegMap lvl SegSpace [Type] (KernelBody rep) | -- | The KernelSpace must always have at least two dimensions, -- implying that the result of a SegRed is always an array.- SegRed lvl SegSpace [SegBinOp rep] [Type] (KernelBody rep)- | SegScan lvl SegSpace [SegBinOp rep] [Type] (KernelBody rep)- | SegHist lvl SegSpace [HistOp rep] [Type] (KernelBody rep)+ SegRed lvl SegSpace [Type] (KernelBody rep) [SegBinOp rep]+ | SegScan lvl SegSpace [Type] (KernelBody rep) [SegBinOp rep]+ | SegHist lvl SegSpace [Type] (KernelBody rep) [HistOp rep] deriving (Eq, Ord, Show) -- | The level of a 'SegOp'.@@ -474,9 +474,9 @@ segBody segop = case segop of SegMap _ _ _ body -> body- SegRed _ _ _ _ body -> body- SegScan _ _ _ _ body -> body- SegHist _ _ _ _ body -> body+ SegRed _ _ _ body _ -> body+ SegScan _ _ _ body _ -> body+ SegHist _ _ _ body _ -> body segResultShape :: SegSpace -> Type -> KernelResult -> Type segResultShape _ t (WriteReturns {}) =@@ -492,7 +492,7 @@ segOpType :: SegOp lvl rep -> [Type] segOpType (SegMap _ space ts kbody) = zipWith (segResultShape space) ts $ kernelBodyResult kbody-segOpType (SegRed _ space reds ts kbody) =+segOpType (SegRed _ space ts kbody reds) = red_ts ++ zipWith (segResultShape space)@@ -505,7 +505,7 @@ op <- reds let shape = Shape segment_dims <> segBinOpShape op map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op)-segOpType (SegScan _ space scans ts kbody) =+segOpType (SegScan _ space ts kbody scans) = scan_ts ++ zipWith (segResultShape space)@@ -517,7 +517,7 @@ op <- scans let shape = Shape (segSpaceDims space) <> segBinOpShape op map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op)-segOpType (SegHist _ space ops _ _) = do+segOpType (SegHist _ space _ _ ops) = do op <- ops let shape = Shape segment_dims <> histShape op <> histOpShape op map (`arrayOfShape` shape) (lambdaReturnType $ histOp op)@@ -533,11 +533,11 @@ consumedInOp (SegMap _ _ _ kbody) = consumedInKernelBody kbody- consumedInOp (SegRed _ _ _ _ kbody) =+ consumedInOp (SegRed _ _ _ kbody _) = consumedInKernelBody kbody- consumedInOp (SegScan _ _ _ _ kbody) =+ consumedInOp (SegScan _ _ _ kbody _) = consumedInKernelBody kbody- consumedInOp (SegHist _ _ ops _ kbody) =+ consumedInOp (SegHist _ _ _ kbody ops) = namesFromList (concatMap histDest ops) <> consumedInKernelBody kbody -- | Type check a 'SegOp', given a checker for its level.@@ -549,7 +549,7 @@ typeCheckSegOp checkLvl (SegMap lvl space ts kbody) = do checkLvl lvl checkScanRed space [] ts kbody-typeCheckSegOp checkLvl (SegRed lvl space reds ts body) = do+typeCheckSegOp checkLvl (SegRed lvl space ts body reds) = do checkLvl lvl checkScanRed space reds' ts body where@@ -558,7 +558,7 @@ (map segBinOpLambda reds) (map segBinOpNeutral reds) (map segBinOpShape reds)-typeCheckSegOp checkLvl (SegScan lvl space scans ts body) = do+typeCheckSegOp checkLvl (SegScan lvl space ts body scans) = do checkLvl lvl checkScanRed space scans' ts body where@@ -567,7 +567,7 @@ (map segBinOpLambda scans) (map segBinOpNeutral scans) (map segBinOpShape scans)-typeCheckSegOp checkLvl (SegHist lvl space ops ts kbody) = do+typeCheckSegOp checkLvl (SegHist lvl space ts kbody ops) = do checkLvl lvl checkSegSpace space mapM_ TC.checkType ts@@ -705,27 +705,27 @@ <*> mapOnSegSpace tv space <*> mapM (mapOnSegOpType tv) ts <*> mapOnSegOpBody tv body-mapSegOpM tv (SegRed lvl space reds ts lam) =+mapSegOpM tv (SegRed lvl space ts body reds) = SegRed <$> mapOnSegOpLevel tv lvl <*> mapOnSegSpace tv space- <*> mapM (mapSegBinOp tv) reds <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts- <*> mapOnSegOpBody tv lam-mapSegOpM tv (SegScan lvl space scans ts body) =+ <*> mapOnSegOpBody tv body+ <*> mapM (mapSegBinOp tv) reds+mapSegOpM tv (SegScan lvl space ts body scans) = SegScan <$> mapOnSegOpLevel tv lvl <*> mapOnSegSpace tv space- <*> mapM (mapSegBinOp tv) scans <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts <*> mapOnSegOpBody tv body-mapSegOpM tv (SegHist lvl space ops ts body) =+ <*> mapM (mapSegBinOp tv) scans+mapSegOpM tv (SegHist lvl space ts body ops) = SegHist <$> mapOnSegOpLevel tv lvl <*> mapOnSegSpace tv space- <*> mapM onHistOp ops <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts <*> mapOnSegOpBody tv body+ <*> mapM onHistOp ops where onHistOp (HistOp w rf arrs nes shape op) = HistOp@@ -771,21 +771,18 @@ instance RephraseOp (SegOp lvl) where rephraseInOp r (SegMap lvl space ts body) = SegMap lvl space ts <$> rephraseKernelBody r body- rephraseInOp r (SegRed lvl space reds ts body) =- SegRed lvl space- <$> mapM (rephraseBinOp r) reds- <*> pure ts- <*> rephraseKernelBody r body- rephraseInOp r (SegScan lvl space scans ts body) =- SegScan lvl space- <$> mapM (rephraseBinOp r) scans- <*> pure ts- <*> rephraseKernelBody r body- rephraseInOp r (SegHist lvl space hists ts body) =- SegHist lvl space- <$> mapM onOp hists- <*> pure ts- <*> rephraseKernelBody r body+ rephraseInOp r (SegRed lvl space ts body reds) =+ SegRed lvl space ts+ <$> rephraseKernelBody r body+ <*> mapM (rephraseBinOp r) reds+ rephraseInOp r (SegScan lvl space ts body scans) =+ SegScan lvl space ts+ <$> rephraseKernelBody r body+ <*> mapM (rephraseBinOp r) scans+ rephraseInOp r (SegHist lvl space ts body hists) =+ SegHist lvl space ts+ <$> rephraseKernelBody r body+ <*> mapM onOp hists where onOp (HistOp w rf arrs nes shape op) = HistOp w rf arrs nes shape <$> rephraseLambda r op@@ -844,15 +841,15 @@ instance (OpMetrics (Op rep)) => OpMetrics (SegOp lvl rep) where opMetrics (SegMap _ _ _ body) = inside "SegMap" $ kernelBodyMetrics body- opMetrics (SegRed _ _ reds _ body) =+ opMetrics (SegRed _ _ _ body reds) = inside "SegRed" $ do mapM_ (inside "SegBinOp" . lambdaMetrics . segBinOpLambda) reds kernelBodyMetrics body- opMetrics (SegScan _ _ scans _ body) =+ opMetrics (SegScan _ _ _ body scans) = inside "SegScan" $ do mapM_ (inside "SegBinOp" . lambdaMetrics . segBinOpLambda) scans kernelBodyMetrics body- opMetrics (SegHist _ _ ops _ body) =+ opMetrics (SegHist _ _ _ body ops) = inside "SegHist" $ do mapM_ (lambdaMetrics . histOp) ops kernelBodyMetrics body@@ -887,30 +884,30 @@ <+> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body)- pretty (SegRed lvl space reds ts body) =+ pretty (SegRed lvl space ts body reds) = "segred" <> pretty lvl </> PP.align (pretty space)- </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty reds) </> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body)- pretty (SegScan lvl space scans ts body) =+ </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty reds)+ pretty (SegScan lvl space ts body scans) = "segscan" <> pretty lvl </> PP.align (pretty space)- </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty scans) </> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body)- pretty (SegHist lvl space ops ts body) =+ </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map pretty scans)+ pretty (SegHist lvl space ts body ops) = "seghist" <> pretty lvl </> PP.align (pretty space)- </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops) </> PP.colon <+> ppTuple' (map pretty ts) <+> PP.nestedBlock "{" "}" (pretty body)+ </> PP.parens (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops) where ppOp (HistOp w rf dests nes shape op) = pretty w@@ -1125,7 +1122,7 @@ ( SegMap lvl' space' ts' kbody', body_hoisted )-simplifySegOp (SegRed lvl space reds ts kbody) = do+simplifySegOp (SegRed lvl space ts kbody reds) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts) (reds', reds_hoisted) <- Engine.localVtable (<> scope_vtable) $@@ -1133,13 +1130,13 @@ (kbody', body_hoisted) <- simplifyKernelBody space kbody pure- ( SegRed lvl' space' reds' ts' kbody',+ ( SegRed lvl' space' ts' kbody' reds', mconcat reds_hoisted <> body_hoisted ) where scope = scopeOfSegSpace space scope_vtable = ST.fromScope scope-simplifySegOp (SegScan lvl space scans ts kbody) = do+simplifySegOp (SegScan lvl space ts kbody scans) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts) (scans', scans_hoisted) <- Engine.localVtable (<> scope_vtable) $@@ -1147,13 +1144,13 @@ (kbody', body_hoisted) <- simplifyKernelBody space kbody pure- ( SegScan lvl' space' scans' ts' kbody',+ ( SegScan lvl' space' ts' kbody' scans', mconcat scans_hoisted <> body_hoisted ) where scope = scopeOfSegSpace space scope_vtable = ST.fromScope scope-simplifySegOp (SegHist lvl space ops ts kbody) = do+simplifySegOp (SegHist lvl space ts kbody ops) = do (lvl', space', ts') <- Engine.simplify (lvl, space, ts) Engine.localVtable (flip (foldr ST.consume) $ concatMap histDest ops) $ do@@ -1176,7 +1173,7 @@ (kbody', body_hoisted) <- simplifyKernelBody space kbody pure- ( SegHist lvl' space' ops' ts' kbody',+ ( SegHist lvl' space' ts' kbody' ops', mconcat ops_hoisted <> body_hoisted ) where@@ -1251,7 +1248,7 @@ -- If a SegRed contains two reduction operations that have the same -- vector shape, merge them together. This saves on communication -- overhead, but can in principle lead to more shared memory usage.-topDownSegOp _ (Pat pes) _ (SegRed lvl space ops ts kbody)+topDownSegOp _ (Pat pes) _ (SegRed lvl space ts kbody ops) | length ops > 1, op_groupings <- groupBy sameShape $@@ -1264,7 +1261,7 @@ pes' = red_pes' ++ map_pes ts' = red_ts' ++ map_ts kbody' = kbody {kernelBodyResult = red_res' ++ map_res}- letBind (Pat pes') $ Op $ segOp $ SegRed lvl space ops' ts' kbody'+ letBind (Pat pes') $ Op $ segOp $ SegRed lvl space ts' kbody' ops' where (red_pes, map_pes) = splitAt (segBinOpResults ops) pes (red_ts, map_ts) = splitAt (segBinOpResults ops) ts@@ -1317,12 +1314,12 @@ ) segOpGuts (SegMap lvl space kts body) = (kts, body, 0, SegMap lvl space)-segOpGuts (SegScan lvl space ops kts body) =- (kts, body, segBinOpResults ops, SegScan lvl space ops)-segOpGuts (SegRed lvl space ops kts body) =- (kts, body, segBinOpResults ops, SegRed lvl space ops)-segOpGuts (SegHist lvl space ops kts body) =- (kts, body, sum $ map (length . histDest) ops, SegHist lvl space ops)+segOpGuts (SegScan lvl space kts body ops) =+ (kts, body, segBinOpResults ops, \t b -> SegScan lvl space t b ops)+segOpGuts (SegRed lvl space kts body ops) =+ (kts, body, segBinOpResults ops, \t b -> SegRed lvl space t b ops)+segOpGuts (SegHist lvl space kts body ops) =+ (kts, body, sum $ map (length . histDest) ops, \t b -> SegHist lvl space t b ops) bottomUpSegOp :: (Aliased rep, HasSegOp rep, BuilderOps rep) =>@@ -1441,9 +1438,9 @@ m [ExpReturns] segOpReturns k@(SegMap _ _ _ kbody) = kernelBodyReturns kbody . extReturns =<< opType k-segOpReturns k@(SegRed _ _ _ _ kbody) =+segOpReturns k@(SegRed _ _ _ kbody _) = kernelBodyReturns kbody . extReturns =<< opType k-segOpReturns k@(SegScan _ _ _ _ kbody) =+segOpReturns k@(SegScan _ _ _ kbody _) = kernelBodyReturns kbody . extReturns =<< opType k-segOpReturns (SegHist _ _ ops _ _) =+segOpReturns (SegHist _ _ _ _ ops) = concat <$> mapM (mapM varReturns . histDest) ops
src/Futhark/Internalise/Exps.hs view
@@ -50,7 +50,15 @@ bindingFParams tparams params $ \shapeparams params' -> do let shapenames = map I.paramName shapeparams all_params = map pure shapeparams ++ concat params'- msg = errorMsg ["Function return value does not match shape of declared return type."]+ msg =+ errorMsg+ [ "Internal runtime error.\n",+ "Return value of ",+ ErrorString (prettyText fname),+ " does not match type shape.\n",+ "This is a bug in the Futhark compiler. Please report this:\n",+ " https://github.com/diku-dk/futhark/issues"+ ] (body', rettype') <- buildBody $ do body_res <- internaliseExp (baseString fname <> "_res") body
src/Futhark/Internalise/Monomorphise.hs view
@@ -829,15 +829,27 @@ onExps bound e1 e2 pure e1 - onExps bound (Var v _ _) e = do- unless (any (`elem` bound) $ freeVarsInExp e) $- modify (M.insert (qualLeaf v) e)- case lookup (qualLeaf v) named1 of- Just rexp -> onExps bound (unReplaced rexp) e- Nothing -> pure ()- onExps bound e (Var v _ _)+ -- XXX: It is intentional that we throw away the 'bound'+ -- information after looking up ExpReplacements, as there are+ -- cases (particularly including the function types that occur+ -- after lambda lifting) where some troublesome shadowing occurs,+ -- and the names are not actually locally bound. We cannot just+ -- ignore the bound information entirely, and expect that any+ -- instantiation uses only names in scope at the outer level, due+ -- to truly exotic cases like entry-lifted.fut, where the real+ -- sizes were not visible to the type checker. Arguably that is+ -- the thing that should be fixed, but it requires fiddling with+ -- the defunctorisation of size-lifted types.++ onExps bound (Var v _ _) e+ | Just rexp <- lookup (qualLeaf v) named1 =+ onExps mempty (unReplaced rexp) e+ | otherwise =+ unless (any (`elem` bound) $ freeVarsInExp e) $+ modify (M.insert (qualLeaf v) e)+ onExps _bound e (Var v _ _) | Just rexp <- lookup (qualLeaf v) named2 =- onExps bound e (unReplaced rexp)+ onExps mempty e (unReplaced rexp) onExps bound e1 e2 | Just es <- similarExps e1 e2 = mapM_ (uncurry $ onExps bound) es
src/Futhark/Optimise/ArrayShortCircuiting.hs view
@@ -166,15 +166,15 @@ replaceInSegOp (SegMap lvl sp tps body) = do stms <- updateStms $ kernelBodyStms body pure $ SegMap lvl sp tps $ body {kernelBodyStms = stms}-replaceInSegOp (SegRed lvl sp binops tps body) = do+replaceInSegOp (SegRed lvl sp tps body binops) = do stms <- updateStms $ kernelBodyStms body- pure $ SegRed lvl sp binops tps $ body {kernelBodyStms = stms}-replaceInSegOp (SegScan lvl sp binops tps body) = do+ pure $ SegRed lvl sp tps (body {kernelBodyStms = stms}) binops+replaceInSegOp (SegScan lvl sp tps body binops) = do stms <- updateStms $ kernelBodyStms body- pure $ SegScan lvl sp binops tps $ body {kernelBodyStms = stms}-replaceInSegOp (SegHist lvl sp hist_ops tps body) = do+ pure $ SegScan lvl sp tps (body {kernelBodyStms = stms}) binops+replaceInSegOp (SegHist lvl sp tps body hist_ops) = do stms <- updateStms $ kernelBodyStms body- pure $ SegHist lvl sp hist_ops tps $ body {kernelBodyStms = stms}+ pure $ SegHist lvl sp tps (body {kernelBodyStms = stms}) hist_ops replaceInHostOp :: HostOp NoOp GPUMem -> UpdateM (HostOp NoOp GPUMem) (HostOp NoOp GPUMem) replaceInHostOp (SegOp op) = SegOp <$> replaceInSegOp op
src/Futhark/Optimise/ArrayShortCircuiting/ArrayCoalescing.hs view
@@ -201,7 +201,7 @@ shortCircuitSegOp lvlOK lutab pat pat_certs (SegMap lvl space _ kernel_body) td_env bu_env = -- No special handling necessary for 'SegMap'. Just call the helper-function. shortCircuitSegOpHelper 0 lvlOK lvl lutab pat pat_certs space kernel_body td_env bu_env-shortCircuitSegOp lvlOK lutab pat pat_certs (SegRed lvl space binops _ kernel_body) td_env bu_env =+shortCircuitSegOp lvlOK lutab pat pat_certs (SegRed lvl space _ kernel_body binops) td_env bu_env = -- When handling 'SegRed', we we first invalidate all active coalesce-entries -- where any of the variables in 'vartab' are also free in the list of -- 'SegBinOp'. In other words, anything that is used as part of the reduction@@ -218,14 +218,14 @@ op <- binops let shp = Shape segment_dims <> segBinOpShape op map (`arrayOfShape` shp) (lambdaReturnType $ segBinOpLambda op)-shortCircuitSegOp lvlOK lutab pat pat_certs (SegScan lvl space binops _ kernel_body) td_env bu_env =+shortCircuitSegOp lvlOK lutab pat pat_certs (SegScan lvl space _ kernel_body binops) td_env bu_env = -- Like in the handling of 'SegRed', we do not want to coalesce anything that -- is used in the 'SegBinOp' let to_fail = M.filter (\entry -> namesFromList (M.keys $ vartab entry) `namesIntersect` foldMap (freeIn . segBinOpLambda) binops) $ activeCoals bu_env (active, inh) = foldl markFailedCoal (activeCoals bu_env, inhibit bu_env) $ M.keys to_fail bu_env' = bu_env {activeCoals = active, inhibit = inh} in shortCircuitSegOpHelper 0 lvlOK lvl lutab pat pat_certs space kernel_body td_env bu_env'-shortCircuitSegOp lvlOK lutab pat pat_certs (SegHist lvl space histops _ kernel_body) td_env bu_env = do+shortCircuitSegOp lvlOK lutab pat pat_certs (SegHist lvl space _ kernel_body histops) td_env bu_env = do -- Need to take zipped patterns and histDest (flattened) and insert transitive coalesces let to_fail = M.filter (\entry -> namesFromList (M.keys $ vartab entry) `namesIntersect` foldMap (freeIn . histOp) histops) $ activeCoals bu_env (active, inh) = foldl markFailedCoal (activeCoals bu_env, inhibit bu_env) $ M.keys to_fail
src/Futhark/Optimise/HistAccs.hs view
@@ -146,7 +146,7 @@ (space', kbody'') <- flatKernelBody space kbody' hist_dest_upd <-- letTupExp "hist_dest_upd" $ Op $ SegOp $ SegHist lvl space' [histop] ts' kbody''+ letTupExp "hist_dest_upd" $ Op $ SegOp $ SegHist lvl space' ts' kbody'' [histop] addStm . Let pat aux =<< addArrsToAcc lvl acc_shape hist_dest_upd acc optimiseStm accs (Let pat aux e) =
src/Futhark/Optimise/MemoryBlockMerging.hs view
@@ -37,11 +37,11 @@ getAllocsSegOp :: SegOp lvl GPUMem -> Allocs getAllocsSegOp (SegMap _ _ _ body) = foldMap getAllocsStm (kernelBodyStms body)-getAllocsSegOp (SegRed _ _ _ _ body) =+getAllocsSegOp (SegRed _ _ _ body _) = foldMap getAllocsStm (kernelBodyStms body)-getAllocsSegOp (SegScan _ _ _ _ body) =+getAllocsSegOp (SegScan _ _ _ body _) = foldMap getAllocsStm (kernelBodyStms body)-getAllocsSegOp (SegHist _ _ _ _ body) =+getAllocsSegOp (SegHist _ _ _ body _) = foldMap getAllocsStm (kernelBodyStms body) setAllocsStm :: Map VName SubExp -> Stm GPUMem -> Stm GPUMem@@ -69,15 +69,18 @@ setAllocsSegOp m (SegMap lvl sp tps body) = SegMap lvl sp tps $ body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body}-setAllocsSegOp m (SegRed lvl sp segbinops tps body) =- SegRed lvl sp segbinops tps $- body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body}-setAllocsSegOp m (SegScan lvl sp segbinops tps body) =- SegScan lvl sp segbinops tps $- body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body}-setAllocsSegOp m (SegHist lvl sp segbinops tps body) =- SegHist lvl sp segbinops tps $- body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body}+setAllocsSegOp m (SegRed lvl sp tps body ops) =+ SegRed lvl sp tps body' ops+ where+ body' = body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body}+setAllocsSegOp m (SegScan lvl sp tps body ops) =+ SegScan lvl sp tps body' ops+ where+ body' = body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body}+setAllocsSegOp m (SegHist lvl sp tps body ops) =+ SegHist lvl sp tps body' ops+ where+ body' = body {kernelBodyStms = setAllocsStm m <$> kernelBodyStms body} maxSubExp :: (MonadBuilder m) => Set SubExp -> m SubExp maxSubExp = helper . S.toList@@ -105,15 +108,15 @@ onKernelBodyStms (SegMap lvl space ts body) f = do stms <- f $ kernelBodyStms body pure $ SegMap lvl space ts $ body {kernelBodyStms = stms}-onKernelBodyStms (SegRed lvl space binops ts body) f = do+onKernelBodyStms (SegRed lvl space ts body binops) f = do stms <- f $ kernelBodyStms body- pure $ SegRed lvl space binops ts $ body {kernelBodyStms = stms}-onKernelBodyStms (SegScan lvl space binops ts body) f = do+ pure $ SegRed lvl space ts (body {kernelBodyStms = stms}) binops+onKernelBodyStms (SegScan lvl space ts body binops) f = do stms <- f $ kernelBodyStms body- pure $ SegScan lvl space binops ts $ body {kernelBodyStms = stms}-onKernelBodyStms (SegHist lvl space binops ts body) f = do+ pure $ SegScan lvl space ts (body {kernelBodyStms = stms}) binops+onKernelBodyStms (SegHist lvl space ts body binops) f = do stms <- f $ kernelBodyStms body- pure $ SegHist lvl space binops ts $ body {kernelBodyStms = stms}+ pure $ SegHist lvl space ts (body {kernelBodyStms = stms}) binops -- | This is the actual optimiser. Given an interference graph and a @SegOp@, -- replace allocations and references to memory blocks inside with a (hopefully)@@ -148,15 +151,18 @@ SegMap lvl sp tps body -> SegMap lvl sp tps $ body {kernelBodyStms = maxstms <> stms <> kernelBodyStms body}- SegRed lvl sp binops tps body ->- SegRed lvl sp binops tps $- body {kernelBodyStms = maxstms <> stms <> kernelBodyStms body}- SegScan lvl sp binops tps body ->- SegScan lvl sp binops tps $- body {kernelBodyStms = maxstms <> stms <> kernelBodyStms body}- SegHist lvl sp binops tps body ->- SegHist lvl sp binops tps $- body {kernelBodyStms = maxstms <> stms <> kernelBodyStms body}+ SegRed lvl sp tps body ops ->+ SegRed lvl sp tps body' ops+ where+ body' = body {kernelBodyStms = maxstms <> stms <> kernelBodyStms body}+ SegScan lvl sp tps body ops ->+ SegScan lvl sp tps body' ops+ where+ body' = body {kernelBodyStms = maxstms <> stms <> kernelBodyStms body}+ SegHist lvl sp tps body ops ->+ SegHist lvl sp tps body' ops+ where+ body' = body {kernelBodyStms = maxstms <> stms <> kernelBodyStms body} -- | Helper function that modifies kernels found inside some statements. onKernels ::
src/Futhark/Optimise/ReduceDeviceSyncs.hs view
@@ -328,15 +328,18 @@ optimizeHostOp :: HostOp op GPU -> ReduceM (HostOp op GPU) optimizeHostOp (SegOp (SegMap lvl space types kbody)) = SegOp . SegMap lvl space types <$> addReadsToKernelBody kbody-optimizeHostOp (SegOp (SegRed lvl space ops types kbody)) = do+optimizeHostOp (SegOp (SegRed lvl space types kbody ops)) = do ops' <- mapM addReadsToSegBinOp ops- SegOp . SegRed lvl space ops' types <$> addReadsToKernelBody kbody-optimizeHostOp (SegOp (SegScan lvl space ops types kbody)) = do+ kbody' <- addReadsToKernelBody kbody+ pure . SegOp $ SegRed lvl space types kbody' ops'+optimizeHostOp (SegOp (SegScan lvl space types kbody ops)) = do ops' <- mapM addReadsToSegBinOp ops- SegOp . SegScan lvl space ops' types <$> addReadsToKernelBody kbody-optimizeHostOp (SegOp (SegHist lvl space ops types kbody)) = do+ kbody' <- addReadsToKernelBody kbody+ pure . SegOp $ SegScan lvl space types kbody' ops'+optimizeHostOp (SegOp (SegHist lvl space types kbody ops)) = do ops' <- mapM addReadsToHistOp ops- SegOp . SegHist lvl space ops' types <$> addReadsToKernelBody kbody+ kbody' <- addReadsToKernelBody kbody+ pure . SegOp $ SegHist lvl space types kbody' ops' optimizeHostOp (SizeOp op) = pure (SizeOp op) optimizeHostOp OtherOp {} =
src/Futhark/Optimise/ReduceDeviceSyncs/MigrationTable.hs view
@@ -1074,15 +1074,15 @@ collectHostOp (SegOp (SegMap lvl sp _ _)) = do collectSegLevel lvl collectSegSpace sp- collectHostOp (SegOp (SegRed lvl sp ops _ _)) = do+ collectHostOp (SegOp (SegRed lvl sp _ _ ops)) = do collectSegLevel lvl collectSegSpace sp mapM_ collectSegBinOp ops- collectHostOp (SegOp (SegScan lvl sp ops _ _)) = do+ collectHostOp (SegOp (SegScan lvl sp _ _ ops)) = do collectSegLevel lvl collectSegSpace sp mapM_ collectSegBinOp ops- collectHostOp (SegOp (SegHist lvl sp ops _ _)) = do+ collectHostOp (SegOp (SegHist lvl sp _ _ ops)) = do collectSegLevel lvl collectSegSpace sp mapM_ collectHistOp ops
src/Futhark/Pass/ExpandAllocations.hs view
@@ -117,28 +117,28 @@ ( alloc_stms, Op $ Inner $ SegOp $ SegMap lvl' space ts kbody' )-transformExp (Op (Inner (SegOp (SegRed lvl space reds ts kbody)))) = do+transformExp (Op (Inner (SegOp (SegRed lvl space ts kbody reds)))) = do (alloc_stms, (lvl', lams, kbody')) <- transformScanRed lvl space (map segBinOpLambda reds) kbody let reds' = zipWith (\red lam -> red {segBinOpLambda = lam}) reds lams pure ( alloc_stms,- Op $ Inner $ SegOp $ SegRed lvl' space reds' ts kbody'+ Op $ Inner $ SegOp $ SegRed lvl' space ts kbody' reds' )-transformExp (Op (Inner (SegOp (SegScan lvl space scans ts kbody)))) = do+transformExp (Op (Inner (SegOp (SegScan lvl space ts kbody scans)))) = do (alloc_stms, (lvl', lams, kbody')) <- transformScanRed lvl space (map segBinOpLambda scans) kbody let scans' = zipWith (\red lam -> red {segBinOpLambda = lam}) scans lams pure ( alloc_stms,- Op $ Inner $ SegOp $ SegScan lvl' space scans' ts kbody'+ Op $ Inner $ SegOp $ SegScan lvl' space ts kbody' scans' )-transformExp (Op (Inner (SegOp (SegHist lvl space ops ts kbody)))) = do+transformExp (Op (Inner (SegOp (SegHist lvl space ts kbody ops)))) = do (alloc_stms, (lvl', lams', kbody')) <- transformScanRed lvl space lams kbody let ops' = zipWith onOp ops lams' pure ( alloc_stms,- Op $ Inner $ SegOp $ SegHist lvl' space ops' ts kbody'+ Op $ Inner $ SegOp $ SegHist lvl' space ts kbody' ops' ) where lams = map histOp ops
src/Futhark/Pass/ExplicitAllocations/GPU.hs view
@@ -105,7 +105,7 @@ pure [Hint lmad $ Space "device"] kernelExpHints (Op (Inner (SegOp (SegMap lvl@(SegThread _ _) space ts body)))) = zipWithM (mapResultHint lvl space) ts $ kernelBodyResult body-kernelExpHints (Op (Inner (SegOp (SegRed lvl@(SegThread _ _) space reds ts body)))) =+kernelExpHints (Op (Inner (SegOp (SegRed lvl@(SegThread _ _) space ts body reds)))) = (map (const NoHint) red_res <>) <$> zipWithM (mapResultHint lvl space) (drop num_reds ts) map_res where num_reds = segBinOpResults reds
src/Futhark/Pass/ExtractKernels/BlockedKernel.hs view
@@ -88,7 +88,7 @@ letBind pat $ Op $ segOp $- SegRed lvl kspace ops (lambdaReturnType map_lam) kbody+ SegRed lvl kspace (lambdaReturnType map_lam) kbody ops segScan :: (MonadFreshNames m, DistRep rep, HasScope rep m) =>@@ -107,7 +107,7 @@ letBind pat $ Op $ segOp $- SegScan lvl kspace ops (lambdaReturnType map_lam) kbody+ SegScan lvl kspace (lambdaReturnType map_lam) kbody ops segMap :: (MonadFreshNames m, DistRep rep, HasScope rep m) =>@@ -197,7 +197,7 @@ forM res $ \(SubExpRes cs se) -> pure $ Returns ResultMaySimplify cs se - letBind pat $ Op $ segOp $ SegHist lvl space ops (lambdaReturnType lam) kbody+ letBind pat $ Op $ segOp $ SegHist lvl space (lambdaReturnType lam) kbody ops mapKernelSkeleton :: (DistRep rep, HasScope rep m, MonadFreshNames m) =>
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -795,7 +795,9 @@ dest_arrs_ts <- mapM (lookupType . kernelInputArray) dest_arrs - let k_body = KernelBody () k_body_stms (zipWith (inPlaceReturn ispace) dest_arrs_ts grouped)+ let k_body =+ KernelBody () k_body_stms $+ zipWith (inPlaceReturn ispace) dest_arrs_ts grouped -- Remove unused kernel inputs, since some of these might -- reference the array we are scattering into. kernel_inps' =@@ -814,15 +816,17 @@ bad = error "Ill-typed nested scatter encountered." inPlaceReturn ispace arr_t (_, inp, is_vs) =- WriteReturns- ( foldMap (foldMap resCerts . fst) is_vs- <> foldMap (resCerts . snd) is_vs- )- (kernelInputArray inp)- [ (fullSlice arr_t $ map DimFix $ map Var (init gtids) ++ map resSubExp is, resSubExp v)- | (is, v) <- is_vs- ]+ WriteReturns write_cs (kernelInputArray inp) $ do+ (is, v) <- is_vs+ pure+ ( fullSlice arr_t . map DimFix $+ map Var (init gtids) ++ map resSubExp is,+ resSubExp v+ ) where+ write_cs =+ foldMap (foldMap resCerts . fst) is_vs+ <> foldMap (resCerts . snd) is_vs (gtids, _ws) = unzip ispace segmentedUpdateKernel ::
src/Futhark/Pass/ExtractKernels/Intrablock.hs view
@@ -300,13 +300,22 @@ space <- mkSegSpace [(write_i, w)] let lam' = soacsLambdaToGPU lam- krets = do- (_a_w, a, is_vs) <-- groupScatterResults dests $ bodyResult $ lambdaBody lam'+ grouped = groupScatterResults dests $ bodyResult $ lambdaBody lam'+ (_, dest_arrs, _) = unzip3 grouped++ dest_ts <- mapM lookupType dest_arrs++ let krets = do+ (a_t, (_a_w, a, is_vs)) <- zip dest_ts grouped let cs = foldMap (foldMap resCerts . fst) is_vs <> foldMap (resCerts . snd) is_vs- is_vs' = [(Slice $ map (DimFix . resSubExp) is, resSubExp v) | (is, v) <- is_vs]+ is_vs' = do+ (is, v) <- is_vs+ pure+ ( fullSlice a_t $ map (DimFix . resSubExp) is,+ resSubExp v+ ) pure $ WriteReturns cs a is_vs' inputs = do (p, p_a) <- zip (lambdaParams lam') ivs
src/Futhark/Pass/ExtractMulticore.hs view
@@ -188,7 +188,7 @@ (reds_stms, reds') <- mapAndUnzipM reduceToSegBinOp reds op' <- renameIfNeeded rename $- SegRed () space reds' (lambdaReturnType map_lam) kbody+ SegRed () space (lambdaReturnType map_lam) kbody reds' pure (reds_stms, op') transformHist ::@@ -205,7 +205,7 @@ (hists_stms, hists') <- mapAndUnzipM histToSegBinOp hists op' <- renameIfNeeded rename $- SegHist () space hists' (lambdaReturnType map_lam) kbody+ SegHist () space (lambdaReturnType map_lam) kbody hists' pure (hists_stms, op') transformSOAC :: Pat Type -> Attrs -> SOAC SOACS -> ExtractM (Stms MC)@@ -245,7 +245,7 @@ ( Let pat (defAux ()) $ Op $ ParOp Nothing $- SegScan () space scans' (lambdaReturnType map_lam) kbody+ SegScan () space (lambdaReturnType map_lam) kbody scans' ) | otherwise = do -- This screma is too complicated for us to immediately do
src/Futhark/Pass/LiftAllocations.hs view
@@ -120,15 +120,15 @@ liftAllocationsInSegOp (SegMap lvl sp tps body) = do stms <- liftAllocationsInStms (kernelBodyStms body) mempty mempty mempty pure $ SegMap lvl sp tps $ body {kernelBodyStms = stms}-liftAllocationsInSegOp (SegRed lvl sp binops tps body) = do+liftAllocationsInSegOp (SegRed lvl sp tps body binops) = do stms <- liftAllocationsInStms (kernelBodyStms body) mempty mempty mempty- pure $ SegRed lvl sp binops tps $ body {kernelBodyStms = stms}-liftAllocationsInSegOp (SegScan lvl sp binops tps body) = do+ pure $ SegRed lvl sp tps (body {kernelBodyStms = stms}) binops+liftAllocationsInSegOp (SegScan lvl sp tps body binops) = do stms <- liftAllocationsInStms (kernelBodyStms body) mempty mempty mempty- pure $ SegScan lvl sp binops tps $ body {kernelBodyStms = stms}-liftAllocationsInSegOp (SegHist lvl sp histops tps body) = do+ pure $ SegScan lvl sp tps (body {kernelBodyStms = stms}) binops+liftAllocationsInSegOp (SegHist lvl sp tps body histops) = do stms <- liftAllocationsInStms (kernelBodyStms body) mempty mempty mempty- pure $ SegHist lvl sp histops tps $ body {kernelBodyStms = stms}+ pure $ SegHist lvl sp tps (body {kernelBodyStms = stms}) histops liftAllocationsInHostOp :: HostOp NoOp (Aliases GPUMem) ->
src/Futhark/Pass/LowerAllocations.hs view
@@ -111,15 +111,15 @@ lowerAllocationsInSegOp (SegMap lvl sp tps body) = do stms <- lowerAllocationsInStms (kernelBodyStms body) mempty mempty pure $ SegMap lvl sp tps $ body {kernelBodyStms = stms}-lowerAllocationsInSegOp (SegRed lvl sp binops tps body) = do+lowerAllocationsInSegOp (SegRed lvl sp tps body binops) = do stms <- lowerAllocationsInStms (kernelBodyStms body) mempty mempty- pure $ SegRed lvl sp binops tps $ body {kernelBodyStms = stms}-lowerAllocationsInSegOp (SegScan lvl sp binops tps body) = do+ pure $ SegRed lvl sp tps (body {kernelBodyStms = stms}) binops+lowerAllocationsInSegOp (SegScan lvl sp tps body binops) = do stms <- lowerAllocationsInStms (kernelBodyStms body) mempty mempty- pure $ SegScan lvl sp binops tps $ body {kernelBodyStms = stms}-lowerAllocationsInSegOp (SegHist lvl sp histops tps body) = do+ pure $ SegScan lvl sp tps (body {kernelBodyStms = stms}) binops+lowerAllocationsInSegOp (SegHist lvl sp tps body histops) = do stms <- lowerAllocationsInStms (kernelBodyStms body) mempty mempty- pure $ SegHist lvl sp histops tps $ body {kernelBodyStms = stms}+ pure $ SegHist lvl sp tps (body {kernelBodyStms = stms}) histops lowerAllocationsInHostOp :: HostOp NoOp GPUMem -> LowerM (HostOp NoOp GPUMem) (HostOp NoOp GPUMem) lowerAllocationsInHostOp (SegOp op) = SegOp <$> lowerAllocationsInSegOp op
src/Language/Futhark/Interpreter.hs view
@@ -51,7 +51,7 @@ import Data.Set qualified as S import Data.Text qualified as T import Futhark.Data qualified as V-import Futhark.Util (chunk, maybeHead)+import Futhark.Util (chunk) import Futhark.Util.Loc import Futhark.Util.Pretty hiding (apply) import Language.Futhark hiding (Shape, matchDims)@@ -62,6 +62,7 @@ import Language.Futhark.Primitive (floatValue, intValue) import Language.Futhark.Primitive qualified as P import Language.Futhark.Semantic qualified as T+import Language.Futhark.TypeChecker.Types (Subst (..), applySubst) import Prelude hiding (break, mod) data StackFrame = StackFrame@@ -331,7 +332,7 @@ lookupVar :: QualName VName -> Env -> Maybe TermBinding lookupVar = lookupInEnv envTerm -lookupType :: QualName VName -> Env -> Maybe (Env, T.TypeBinding)+lookupType :: QualName VName -> Env -> Maybe TypeBinding lookupType = lookupInEnv envType -- | A TermValue with a 'Nothing' type annotation is an intrinsic or@@ -349,6 +350,9 @@ show (TermPoly bv _) = unwords ["TermPoly", show bv] show (TermModule m) = unwords ["TermModule", show m] +data TypeBinding = TypeBinding Env [TypeParam] StructRetType+ deriving (Show)+ data Module = Module Env | ModuleFun (Module -> EvalM Module)@@ -360,7 +364,7 @@ -- | The actual type- and value environment. data Env = Env { envTerm :: M.Map VName TermBinding,- envType :: M.Map VName (Env, T.TypeBinding)+ envType :: M.Map VName TypeBinding } deriving (Show) @@ -400,7 +404,7 @@ envType = M.map tbind m } where- tbind = (mempty,) . T.TypeAbbr Unlifted [] . RetType []+ tbind = TypeBinding mempty [] . RetType [] i64Env :: M.Map VName Int64 -> Env i64Env = valEnv . M.map f@@ -647,17 +651,17 @@ in second (const u) (arrayOf shape' $ toStruct et') expandType env (Scalar (TypeVar u tn args)) = case lookupType tn env of- Just (tn_env, T.TypeAbbr _ ps (RetType ext t')) ->+ Just (TypeBinding tn_env ps (RetType ext t')) -> let (substs, types) = mconcat $ zipWith matchPtoA ps args- onDim (SizeClosure _ (Var v _ _))- | Just e <- M.lookup (qualLeaf v) substs =- SizeClosure env e- -- The next case can occur when a type with existential size- -- has been hidden by a module ascription,- -- e.g. tests/modules/sizeparams4.fut.- onDim (SizeClosure _ e)- | any (`elem` ext) $ fvVars $ freeInExp e = SizeClosure mempty anySize- onDim d = d+ 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.+ -- tests/modules/sizeparams4.fut.+ SizeClosure mempty anySize+ | otherwise =+ SizeClosure (env <> dim_env) $+ applySubst (`M.lookup` substs) dim in bimap onDim (const u) $ expandType (Env mempty types <> tn_env) t' Nothing -> -- This case only happens for built-in abstract types,@@ -665,10 +669,10 @@ Scalar (TypeVar u tn $ map expandArg args) where matchPtoA (TypeParamDim p _) (TypeArgDim e) =- (M.singleton p e, mempty)- matchPtoA (TypeParamType l p _) (TypeArgType t') =+ (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 (mempty, T.TypeAbbr l [] $ RetType [] t''))+ in (mempty, M.singleton p (TypeBinding mempty [] $ RetType [] t'')) matchPtoA _ _ = mempty expandArg (TypeArgDim s) = TypeArgDim $ SizeClosure env s expandArg (TypeArgType t) = TypeArgType $ expandType env t@@ -999,7 +1003,7 @@ eval env (Ascript e _ _) = eval env e eval env (Coerce e te (Info t) loc) = do v <- eval env e- t' <- evalTypeFully $ expandType env $ toStruct t+ t' <- evalTypeFully $ expandType env t case checkShape (typeShape t') (valueShape v) of Just _ -> pure v Nothing ->@@ -1121,13 +1125,12 @@ where rev_substs = reverseSubstitutions substs replace v = fromMaybe [v] $ M.lookup v rev_substs- replaceQ v = maybe v qualName $ maybeHead =<< M.lookup (qualLeaf v) rev_substs replaceM f m = M.fromList $ do (k, v) <- M.toList m k' <- replace k pure (k', f v) onEnv (Env terms types) =- Env (replaceM onTerm terms) (replaceM (bimap onEnv onType) types)+ Env (replaceM onTerm terms) (replaceM onType types) onModule (Module env) = Module $ onEnv env onModule (ModuleFun f) =@@ -1135,10 +1138,7 @@ onTerm (TermValue t v) = TermValue t v onTerm (TermPoly t v) = TermPoly t v onTerm (TermModule m) = TermModule $ onModule m- onType (T.TypeAbbr l ps t) = T.TypeAbbr l ps $ first onDim t- onDim (Var v typ loc) = Var (replaceQ v) typ loc- onDim (IntLit x t loc) = IntLit x t loc- onDim _ = error "Arbitrary expression not supported yet"+ onType (TypeBinding env ps t) = TypeBinding (onEnv env) ps t evalModuleVar :: Env -> QualName VName -> EvalM Module evalModuleVar env qv =@@ -1216,8 +1216,8 @@ evalDec env $ LocalDec (OpenDec (ModImport name name' loc) loc) loc evalDec env (LocalDec d _) = evalDec env d evalDec env ModTypeDec {} = pure env-evalDec env (TypeDec (TypeBind v l ps _ (Info (RetType dims t)) _ _)) = do- let abbr = (env, T.TypeAbbr l ps . RetType dims $ evalToStruct $ expandType env t)+evalDec env (TypeDec (TypeBind v _ ps _ (Info (RetType dims t)) _ _)) = do+ let abbr = TypeBinding env ps $ RetType dims t pure env {envType = M.insert v abbr $ envType env} evalDec env (ModDec (ModBind v ps ret body _ loc)) = do (mod_env, mod) <- evalModExp env $ wrapInLambda ps@@ -2095,10 +2095,10 @@ def s | nameFromText s `M.member` namesToPrimTypes = Nothing def s = error $ "Missing intrinsic: " ++ T.unpack s - tdef :: Name -> Maybe (Env, T.TypeBinding)+ tdef :: Name -> Maybe TypeBinding tdef s = do t <- s `M.lookup` namesToPrimTypes- pure (mempty, T.TypeAbbr Unlifted [] $ RetType [] $ Scalar $ Prim t)+ pure $ TypeBinding mempty [] $ RetType [] $ Scalar $ Prim t intrinsicVal :: Name -> Value intrinsicVal name =