futhark 0.20.1 → 0.20.2
raw patch · 50 files changed
+503/−436 lines, 50 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Futhark.IR.Mem.IxFun: equivalent :: Eq num => IxFun num -> IxFun num -> Bool
+ Futhark.Util.Options: optionsError :: String -> IO ()
- Futhark.Internalise.AccurateSizes: argShapes :: (HasScope SOACS m, Monad m) => [VName] -> [FParam] -> [Type] -> m [SubExp]
+ Futhark.Internalise.AccurateSizes: argShapes :: [VName] -> [FParam] -> [Type] -> InternaliseM [SubExp]
- Futhark.Optimise.InPlaceLowering.SubstituteIndices: substituteIndices :: (MonadFreshNames m, BuilderOps rep, Buildable rep, Aliased rep, LetDec rep ~ dec) => IndexSubstitutions dec -> Stms rep -> m (IndexSubstitutions dec, Stms rep)
+ Futhark.Optimise.InPlaceLowering.SubstituteIndices: substituteIndices :: (MonadFreshNames m, BuilderOps rep, Buildable rep, Aliased rep, LParamInfo rep ~ Type) => IndexSubstitutions -> Stms rep -> m (IndexSubstitutions, Stms rep)
- Futhark.Optimise.InPlaceLowering.SubstituteIndices: type IndexSubstitution dec = (Certs, VName, dec, Slice SubExp)
+ Futhark.Optimise.InPlaceLowering.SubstituteIndices: type IndexSubstitution = (Certs, VName, Type, Slice SubExp)
- Futhark.Optimise.InPlaceLowering.SubstituteIndices: type IndexSubstitutions dec = [(VName, IndexSubstitution dec)]
+ Futhark.Optimise.InPlaceLowering.SubstituteIndices: type IndexSubstitutions = [(VName, IndexSubstitution)]
Files
- docs/language-reference.rst +2/−1
- futhark.cabal +1/−1
- rts/javascript/values.js +35/−4
- src/Futhark/Analysis/HORep/SOAC.hs +18/−18
- src/Futhark/Analysis/Rephrase.hs +2/−2
- src/Futhark/Analysis/SymbolTable.hs +6/−6
- src/Futhark/CLI/Bench.hs +5/−9
- src/Futhark/CLI/Test.hs +3/−3
- src/Futhark/CodeGen/Backends/COpenCL.hs +3/−3
- src/Futhark/CodeGen/ImpGen.hs +14/−9
- src/Futhark/Construct.hs +5/−5
- src/Futhark/IR/Aliases.hs +14/−14
- src/Futhark/IR/Mem/IxFun.hs +25/−1
- src/Futhark/IR/Pretty.hs +3/−3
- src/Futhark/IR/SOACS/Simplify.hs +4/−4
- src/Futhark/IR/SegOp.hs +3/−3
- src/Futhark/Internalise/AccurateSizes.hs +2/−9
- src/Futhark/Internalise/Exps.hs +26/−31
- src/Futhark/Internalise/Monad.hs +1/−1
- src/Futhark/Optimise/CSE.hs +3/−3
- src/Futhark/Optimise/DoubleBuffer.hs +2/−2
- src/Futhark/Optimise/Fusion.hs +41/−41
- src/Futhark/Optimise/Fusion/Composing.hs +4/−4
- src/Futhark/Optimise/InPlaceLowering.hs +17/−17
- src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +21/−20
- src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +49/−45
- src/Futhark/Optimise/Simplify/Engine.hs +16/−15
- src/Futhark/Optimise/Simplify/Rep.hs +7/−7
- src/Futhark/Optimise/Simplify/Rule.hs +5/−5
- src/Futhark/Optimise/Simplify/Rules.hs +5/−0
- src/Futhark/Optimise/Simplify/Rules/BasicOp.hs +3/−3
- src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs +4/−4
- src/Futhark/Optimise/Simplify/Rules/Index.hs +4/−4
- src/Futhark/Optimise/Simplify/Rules/Loop.hs +2/−2
- src/Futhark/Optimise/TileLoops.hs +3/−2
- src/Futhark/Optimise/TileLoops/Shared.hs +7/−7
- src/Futhark/Pass/ExpandAllocations.hs +4/−4
- src/Futhark/Pass/ExplicitAllocations.hs +9/−9
- src/Futhark/Pass/ExtractKernels.hs +19/−19
- src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +2/−2
- src/Futhark/Pass/ExtractKernels/DistributeNests.hs +37/−37
- src/Futhark/Pass/ExtractKernels/Distribution.hs +7/−7
- src/Futhark/Pass/ExtractKernels/ISRWIM.hs +6/−6
- src/Futhark/Pass/ExtractKernels/Interchange.hs +9/−9
- src/Futhark/Pass/ExtractKernels/Intragroup.hs +2/−2
- src/Futhark/Pass/ExtractKernels/StreamKernel.hs +2/−2
- src/Futhark/Pass/KernelBabysitting.hs +6/−6
- src/Futhark/TypeCheck.hs +19/−19
- src/Futhark/Util/Options.hs +10/−0
- src/Language/Futhark/TypeChecker/Terms.hs +6/−6
docs/language-reference.rst view
@@ -21,7 +21,8 @@ ------------------------ .. productionlist::- id: `letter` (`letter` | "_" | "'")* | "_" `id`+ id: `letter` `constituent`* | "_" `constituent`*+ constituent: `letter` | `digit` | "_" | "'" quals: (`id` ".")+ qualid: `id` | `quals` `id` binop: `opstartchar` `opchar`*
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark-version: 0.20.1+version: 0.20.2 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to
rts/javascript/values.js view
@@ -1,5 +1,20 @@ // Start of values.js+var futharkPrimtypes =+ new Set([+ 'i8',+ 'i16',+ 'i32',+ 'i64',+ 'u8',+ 'u16',+ 'u32',+ 'u64',+ 'f16',+ 'f32',+ 'f64',+ 'bool']); + var typToType = { ' i8' : Int8Array , ' i16' : Int16Array , ' i32' : Int32Array ,@@ -124,7 +139,7 @@ } } - read_binary() {+ read_binary(typename, dim) { // Skip leading white space while (this.buff.slice(0, 1).toString().trim() == "") { this.buff = this.buff.slice(1);@@ -139,7 +154,14 @@ var num_dim = this.buff[2]; var typ = this.buff.slice(3, 7); this.buff = this.buff.slice(7);- if (num_dim == 0) {+ var exp_typ = "[]".repeat(dim) + typename;+ var given_typ = "[]".repeat(num_dim) + typ.toString().trim();+ console.log(exp_typ);+ console.log(given_typ);+ if (exp_typ !== given_typ) {+ throw ("Expected type : " + exp_typ + ", Actual type : " + given_typ);+ }+ if (num_dim === 0) { return this.read_bin_scalar(typ); } else { return this.read_bin_array(num_dim, typ);@@ -157,8 +179,17 @@ } function read_value(typename, reader) {- // TODO include typename in implementation- var val = reader.read_binary();+ var typ = typename;+ var dim = 0;+ while (typ.slice(0, 2) === "[]") {+ dim = dim + 1;+ typ = typ.slice(2);+ }+ if (!futharkPrimtypes.has(typ)) {+ throw ("Unkown type: " + typ);+ }++ var val = reader.read_binary(typ, dim); return val; }
src/Futhark/Analysis/HORep/SOAC.hs view
@@ -547,8 +547,8 @@ let insoac = Futhark.Screma chvar (map paramName strm_inpids) $ Futhark.mapSOAC lam'- insbnd = mkLet strm_resids $ Op insoac- strmbdy = mkBody (oneStm insbnd) $ map (subExpRes . Futhark.Var . identName) strm_resids+ insstm = mkLet strm_resids $ Op insoac+ strmbdy = mkBody (oneStm insstm) $ map (subExpRes . Futhark.Var . identName) strm_resids strmpar = chunk_param : strm_inpids strmlam = Lambda strmpar strmbdy loutps empty_lam = Lambda [] (mkBody mempty []) []@@ -581,25 +581,25 @@ inpacc_ids <- mapM (newParam "inpacc") accrtps outszm1id <- newIdent "szm1" $ Prim int64 -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam,nes,map_lam,a_ch)- let insbnd =+ let insstm = mkLet (scan0_ids ++ map_resids) . Op $ Futhark.Screma chvar (map paramName strm_inpids) $ Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam' -- 2. let outerszm1id = chunksize - 1- outszm1bnd =+ outszm1stm = mkLet [outszm1id] . BasicOp $ BinOp (Sub Int64 OverflowUndef) (Futhark.Var $ paramName chunk_param) (constant (1 :: Int64)) -- 3. let lasteel_ids = ...- empty_arr_bnd =+ empty_arr_stm = mkLet [empty_arr] . BasicOp $ CmpOp (CmpSlt Int64) (Futhark.Var $ identName outszm1id) (constant (0 :: Int64))- leltmpbnds =+ leltmpstms = zipWith ( \lid arrid -> mkLet [lid] . BasicOp $@@ -610,18 +610,18 @@ ) lastel_tmp_ids scan0_ids- lelbnd =+ lelstm = mkLet lastel_ids $ If (Futhark.Var $ identName empty_arr) (mkBody mempty $ subExpsRes nes)- ( mkBody (stmsFromList leltmpbnds) $+ ( mkBody (stmsFromList leltmpstms) $ varsRes $ map identName lastel_tmp_ids ) $ ifCommon $ map identType lastel_tmp_ids -- 4. let strm_resids = map (acc `+`,nes, scan0_ids) maplam <- mkMapPlusAccLam (map (Futhark.Var . paramName) inpacc_ids) scan_lam- let mapbnd =+ let mapstm = mkLet strm_resids . Op $ Futhark.Screma chvar (map identName scan0_ids) (Futhark.mapSOAC maplam) -- 5. let acc' = acc + lasteel_ids@@ -630,9 +630,9 @@ map Futhark.Var $ map paramName inpacc_ids ++ map identName lastel_ids -- Finally, construct the stream- let (addlelbnd, addlelres) = (bodyStms addlelbdy, bodyResult addlelbdy)+ let (addlelstm, addlelres) = (bodyStms addlelbdy, bodyResult addlelbdy) strmbdy =- mkBody (stmsFromList [insbnd, outszm1bnd, empty_arr_bnd, lelbnd, mapbnd] <> addlelbnd) $+ mkBody (stmsFromList [insstm, outszm1stm, empty_arr_stm, lelstm, mapstm] <> addlelstm) $ addlelres ++ map (subExpRes . Futhark.Var . identName) (strm_resids ++ map_resids) strmpar = chunk_param : inpacc_ids ++ strm_inpids strmlam = Lambda strmpar strmbdy (accrtps ++ loutps)@@ -662,16 +662,16 @@ chvar (map paramName strm_inpids) $ Futhark.redomapSOAC [Futhark.Reduce comm lamin nes] foldlam- insbnd = mkLet (acc0_ids ++ strm_resids) $ Op insoac+ insstm = mkLet (acc0_ids ++ strm_resids) $ Op insoac -- 2. let acc' = acc + acc0_ids in addaccbdy <- mkPlusBnds lamin $ map Futhark.Var $ map paramName inpacc_ids ++ map identName acc0_ids -- Construct the stream- let (addaccbnd, addaccres) = (bodyStms addaccbdy, bodyResult addaccbdy)+ let (addaccstm, addaccres) = (bodyStms addaccbdy, bodyResult addaccbdy) strmbdy =- mkBody (oneStm insbnd <> addaccbnd) $+ mkBody (oneStm insstm <> addaccstm) $ addaccres ++ map (subExpRes . Futhark.Var . identName) strm_resids strmpar = chunk_param : inpacc_ids ++ strm_inpids strmlam = Lambda strmpar strmbdy (accrtps ++ loutps')@@ -688,7 +688,7 @@ m (Lambda rep) mkMapPlusAccLam accs plus = do let (accpars, rempars) = splitAt (length accs) $ lambdaParams plus- parbnds =+ parstms = zipWith (\par se -> mkLet [paramIdent par] (BasicOp $ SubExp se)) accpars@@ -697,7 +697,7 @@ newlambdy = Body (bodyDec plus_bdy)- (stmsFromList parbnds <> bodyStms plus_bdy)+ (stmsFromList parstms <> bodyStms plus_bdy) (bodyResult plus_bdy) renameLambda $ Lambda rempars newlambdy $ lambdaReturnType plus @@ -708,10 +708,10 @@ m (Body rep) mkPlusBnds plus accels = do plus' <- renameLambda plus- let parbnds =+ let parstms = zipWith (\par se -> mkLet [paramIdent par] (BasicOp $ SubExp se)) (lambdaParams plus') accels body = lambdaBody plus'- return $ body {bodyStms = stmsFromList parbnds <> bodyStms body}+ return $ body {bodyStms = stmsFromList parstms <> bodyStms body}
src/Futhark/Analysis/Rephrase.hs view
@@ -80,10 +80,10 @@ -- | Rephrase a body. rephraseBody :: Monad m => Rephraser m from to -> Body from -> m (Body to)-rephraseBody rephraser (Body rep bnds res) =+rephraseBody rephraser (Body rep stms res) = Body <$> rephraseBodyDec rephraser rep- <*> (stmsFromList <$> mapM (rephraseStm rephraser) (stmsToList bnds))+ <*> (stmsFromList <$> mapM (rephraseStm rephraser) (stmsToList stms)) <*> pure res -- | Rephrase a lambda.
src/Futhark/Analysis/SymbolTable.hs view
@@ -350,14 +350,14 @@ Names -> Stm rep -> LetBoundEntry rep-defBndEntry vtable patElem als bnd =+defBndEntry vtable patElem als stm = LetBoundEntry { letBoundDec = patElemDec patElem, letBoundAliases = als,- letBoundStm = bnd,+ letBoundStm = stm, letBoundIndex = \k ->- fmap (indexedAddCerts (stmAuxCerts $ stmAux bnd))- . indexExp vtable (stmExp bnd) k+ fmap (indexedAddCerts (stmAuxCerts $ stmAux stm))+ . indexExp vtable (stmExp stm) k } bindingEntries ::@@ -365,9 +365,9 @@ Stm rep -> SymbolTable rep -> [LetBoundEntry rep]-bindingEntries bnd@(Let pat _ _) vtable = do+bindingEntries stm@(Let pat _ _) vtable = do pat_elem <- patElems pat- return $ defBndEntry vtable pat_elem (Aliases.aliasesOf pat_elem) bnd+ return $ defBndEntry vtable pat_elem (Aliases.aliasesOf pat_elem) stm adjustSeveral :: Ord k => (v -> v) -> [k] -> M.Map k v -> M.Map k v adjustSeveral f = flip $ foldl' $ flip $ M.adjust f
src/Futhark/CLI/Bench.hs view
@@ -230,7 +230,7 @@ cell i | i' * step_size <= cur' = char 9 | otherwise =- char (floor (((cur' - (i' -1) * step_size) * num_chars) / step_size))+ char (floor (((cur' - (i' - 1) * step_size) * num_chars) / step_size)) where i' = fromIntegral i @@ -359,7 +359,7 @@ { optRuns = n' } _ ->- Left $ error $ "'" ++ n ++ "' is not a positive integer."+ Left . optionsError $ "'" ++ n ++ "' is not a positive integer." ) "RUNS" )@@ -427,12 +427,8 @@ | n' < max_timeout -> Right $ \config -> config {optTimeout = fromIntegral n'} _ ->- Left $- error $- "'" ++ n- ++ "' is not an integer smaller than"- ++ show max_timeout- ++ "."+ Left . optionsError $+ "'" ++ n ++ "' is not an integer smaller than" ++ show max_timeout ++ "." ) "SECONDS" )@@ -495,7 +491,7 @@ | n' > 0 -> Right $ \config -> config {optConcurrency = Just n'} _ ->- Left $ error $ "'" ++ n ++ "' is not a positive integer."+ Left . optionsError $ "'" ++ n ++ "' is not a positive integer." ) "NUM" )
src/Futhark/CLI/Test.hs view
@@ -277,8 +277,8 @@ Left (CmdFailure _ err) -> pure [Failure err] Right (output_types', input_types') -> do- let outs = ["out" <> T.pack (show i) | i <- [0 .. length output_types' -1]]- ins = ["in" <> T.pack (show i) | i <- [0 .. length input_types' -1]]+ let outs = ["out" <> T.pack (show i) | i <- [0 .. length output_types' - 1]]+ ins = ["in" <> T.pack (show i) | i <- [0 .. length input_types' - 1]] onRes = either (Failure . pure) (const Success) mapM (fmap onRes . runCompiledCase input_types' outs ins) run_cases where@@ -732,7 +732,7 @@ | n' > 0 -> Right $ \config -> config {configConcurrency = Just n'} _ ->- Left $ error $ "'" ++ n ++ "' is not a positive integer."+ Left . optionsError $ "'" ++ n ++ "' is not a positive integer." ) "NUM" )
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -423,10 +423,10 @@ ++ dims ++ " and local work size " ++ dims- ++ "]; local memory: %d bytes.\n",+ ++ "; local memory: %d bytes.\n", [C.cexp|$string:(pretty kernel_name)|] :- map (kernelDim global_work_size) [0 .. kernel_rank -1]- ++ map (kernelDim local_work_size) [0 .. kernel_rank -1]+ map (kernelDim global_work_size) [0 .. kernel_rank - 1]+ ++ map (kernelDim local_work_size) [0 .. kernel_rank - 1] ++ [[C.cexp|(int)$exp:local_bytes|]] ) where
src/Futhark/CodeGen/ImpGen.hs view
@@ -666,18 +666,18 @@ return (outparams, inparams, results, args) compileBody :: Pat rep -> Body rep -> ImpM rep r op ()-compileBody pat (Body _ bnds ses) = do+compileBody pat (Body _ stms ses) = do dests <- destinationFromPat pat- compileStms (freeIn ses) bnds $+ compileStms (freeIn ses) stms $ forM_ (zip dests ses) $ \(d, SubExpRes _ se) -> copyDWIMDest d [] se [] compileBody' :: [Param dec] -> Body rep -> ImpM rep r op ()-compileBody' params (Body _ bnds ses) =- compileStms (freeIn ses) bnds $+compileBody' params (Body _ stms ses) =+ compileStms (freeIn ses) stms $ forM_ (zip params ses) $ \(param, SubExpRes _ se) -> copyDWIM (paramName param) [] se [] compileLoopBody :: Typed dec => [Param dec] -> Body rep -> ImpM rep r op ()-compileLoopBody mergeparams (Body _ bnds ses) = do+compileLoopBody mergeparams (Body _ stms ses) = do -- We cannot write the results to the merge parameters immediately, -- as some of the results may actually *be* merge parameters, and -- would thus be clobbered. Therefore, we first copy to new@@ -685,7 +685,7 @@ -- buffer to the merge parameters. This is efficient, because the -- operations are all scalar operations. tmpnames <- mapM (newVName . (++ "_tmp") . baseString . paramName) mergeparams- compileStms (freeIn ses) bnds $ do+ compileStms (freeIn ses) stms $ do copy_to_merge_params <- forM (zip3 mergeparams tmpnames ses) $ \(p, tmp, SubExpRes _ se) -> case typeOf p of Prim pt -> do@@ -1367,9 +1367,14 @@ -- More complicated read/write operations that use index functions. copy :: CopyCompiler rep r op-copy bt dest src = do- cc <- asks envCopyCompiler- cc bt dest src+copy bt dest src =+ unless+ ( memLocName dest == memLocName src+ && memLocIxFun dest `IxFun.equivalent` memLocIxFun src+ )+ $ do+ cc <- asks envCopyCompiler+ cc bt dest src -- | Is this copy really a mapping with transpose? isMapTransposeCopy ::
src/Futhark/Construct.hs view
@@ -515,8 +515,8 @@ m (Body (Rep m)) -> m (Body (Rep m)) insertStmsM m = do- (Body _ bnds res, otherbnds) <- collectStms m- mkBodyM (otherbnds <> bnds) res+ (Body _ stms res, otherstms) <- collectStms m+ mkBodyM (otherstms <> stms) res -- | Evaluate an action that produces a 'Result' and an auxiliary -- value, then return the body constructed from the 'Result' and any@@ -544,9 +544,9 @@ (Result -> Body rep) -> Body rep -> Body rep-mapResult f (Body _ bnds res) =- let Body _ bnds2 newres = f res- in mkBody (bnds <> bnds2) newres+mapResult f (Body _ stms res) =+ let Body _ stms2 newres = f res+ in mkBody (stms <> stms2) newres -- | Instantiate all existential parts dimensions of the given -- type, using a monadic action to create the necessary t'SubExp's.
src/Futhark/IR/Aliases.hs view
@@ -242,8 +242,8 @@ Stms (Aliases rep) -> Result -> Body (Aliases rep)-mkAliasedBody dec bnds res =- Body (mkBodyAliases bnds res, dec) bnds res+mkAliasedBody dec stms res =+ Body (mkBodyAliases stms res, dec) stms res mkPatAliases :: (Aliased rep, Typed dec) =>@@ -271,13 +271,13 @@ Stms rep -> Result -> BodyAliasing-mkBodyAliases bnds res =- -- We need to remove the names that are bound in bnds from the alias+mkBodyAliases stms res =+ -- We need to remove the names that are bound in stms from the alias -- and consumption sets. We do this by computing the transitive- -- closure of the alias map (within bnds), then removing anything- -- bound in bnds.- let (aliases, consumed) = mkStmsAliases bnds res- boundNames = foldMap (namesFromList . patNames . stmPat) bnds+ -- closure of the alias map (within stms), then removing anything+ -- bound in stms.+ let (aliases, consumed) = mkStmsAliases stms res+ boundNames = foldMap (namesFromList . patNames . stmPat) stms aliases' = map (`namesSubtract` boundNames) aliases consumed' = consumed `namesSubtract` boundNames in (map AliasDec aliases', AliasDec consumed')@@ -289,14 +289,14 @@ Stms rep -> Result -> ([Names], Names)-mkStmsAliases bnds res = delve mempty $ stmsToList bnds+mkStmsAliases stms res = delve mempty $ stmsToList stms where delve (aliasmap, consumed) [] = ( map (aliasClosure aliasmap . subExpAliases . resSubExp) res, consumed )- delve (aliasmap, consumed) (bnd : bnds') =- delve (trackAliases (aliasmap, consumed) bnd) bnds'+ delve (aliasmap, consumed) (stm : stms') =+ delve (trackAliases (aliasmap, consumed) stm) stms' aliasClosure aliasmap names = names <> mconcat (map look $ namesToList names) where@@ -355,8 +355,8 @@ Let pat dec _ <- mkLetNames names $ removeExpAliases e return $ mkAliasedLetStm pat dec e - mkBody bnds res =- let Body bodyrep _ _ = mkBody (fmap removeStmAliases bnds) res- in mkAliasedBody bodyrep bnds res+ mkBody stms res =+ let Body bodyrep _ _ = mkBody (fmap removeStmAliases stms) res+ in mkAliasedBody bodyrep stms res instance (ASTRep (Aliases rep), Buildable (Aliases rep)) => BuilderOps (Aliases rep)
src/Futhark/IR/Mem/IxFun.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -27,6 +28,7 @@ leastGeneralGeneralization, existentialize, closeEnough,+ equivalent, ) where @@ -530,7 +532,9 @@ & setLMADPermutation [0 ..] in IxFun (lmad :| lmads) oshp cg where- helper s0 (FlatDimIndex n s) = LMADDim (s0 * s) 0 n 0 Unknown+ helper s0 (FlatDimIndex n s) =+ let new_mon = if s0 * s == 1 then Inc else Unknown+ in LMADDim (s0 * s) 0 n 0 new_mon flatSlice (IxFun (lmad :| lmads) oshp cg) s@(FlatSlice new_offset _) = IxFun (LMAD (new_offset * base_stride) (new_dims <> tail_dims) :| lmad : lmads) oshp cg where@@ -1043,3 +1047,23 @@ length (lmadDims lmad1) == length (lmadDims lmad2) && map ldPerm (lmadDims lmad1) == map ldPerm (lmadDims lmad2)++-- | Returns true if two 'IxFun's are equivalent.+--+-- Equivalence in this case is defined as having the same number of LMADs, with+-- each pair of LMADs matching in permutation, offsets, strides and rotations.+equivalent :: Eq num => IxFun num -> IxFun num -> Bool+equivalent ixf1 ixf2 =+ NE.length (ixfunLMADs ixf1) == NE.length (ixfunLMADs ixf2)+ && all closeEnoughLMADs (NE.zip (ixfunLMADs ixf1) (ixfunLMADs ixf2))+ where+ closeEnoughLMADs (lmad1, lmad2) =+ length (lmadDims lmad1) == length (lmadDims lmad2)+ && map ldPerm (lmadDims lmad1)+ == map ldPerm (lmadDims lmad2)+ && lmadOffset lmad1+ == lmadOffset lmad2+ && map ldStride (lmadDims lmad1)+ == map ldStride (lmadDims lmad2)+ && map ldRotate (lmadDims lmad1)+ == map ldRotate (lmadDims lmad2)
src/Futhark/IR/Pretty.hs view
@@ -142,7 +142,7 @@ ppr (Param name t) = ppr name <+> colon <+> align (ppr t) instance PrettyRep rep => Pretty (Stm rep) where- ppr bnd@(Let pat aux e) =+ ppr stm@(Let pat aux e) = align . hang 2 $ text "let" <+> align (ppr pat) <+> case (linebreak, stmannot) of@@ -161,8 +161,8 @@ stmannot = concat [ maybeToList (ppExpDec (stmAuxDec aux) e),- stmAttrAnnots bnd,- stmCertAnnots bnd+ stmAttrAnnots stm,+ stmCertAnnots stm ] instance Pretty a => Pretty (Slice a) where
src/Futhark/IR/SOACS/Simplify.hs view
@@ -348,16 +348,16 @@ removeReplicateMapping vtable pat aux op | Just (Screma w arrs form) <- asSOAC op, Just fun <- isMapSOAC form,- Just (bnds, fun', arrs') <- removeReplicateInput vtable fun arrs = Simplify $ do- forM_ bnds $ \(vs, cs, e) -> certifying cs $ letBindNames vs e+ Just (stms, fun', arrs') <- removeReplicateInput vtable fun arrs = Simplify $ do+ forM_ stms $ \(vs, cs, e) -> certifying cs $ letBindNames vs e auxing aux $ letBind pat $ Op $ soacOp $ Screma w arrs' $ mapSOAC fun' removeReplicateMapping _ _ _ _ = Skip -- | Like 'removeReplicateMapping', but for 'Scatter'. removeReplicateWrite :: TopDownRuleOp (Wise SOACS) removeReplicateWrite vtable pat aux (Scatter len lam ivs as)- | Just (bnds, lam', ivs') <- removeReplicateInput vtable lam ivs = Simplify $ do- forM_ bnds $ \(vs, cs, e) -> certifying cs $ letBindNames vs e+ | Just (stms, lam', ivs') <- removeReplicateInput vtable lam ivs = Simplify $ do+ forM_ stms $ \(vs, cs, e) -> certifying cs $ letBindNames vs e auxing aux $ letBind pat $ Op $ Scatter len lam' ivs' as removeReplicateWrite _ _ _ _ = Skip
src/Futhark/IR/SegOp.hs view
@@ -1090,9 +1090,9 @@ Stms (Wise rep) -> [KernelResult] -> KernelBody (Wise rep)-mkWiseKernelBody dec bnds res =- let Body dec' _ _ = mkWiseBody dec bnds $ subExpsRes res_vs- in KernelBody dec' bnds res+mkWiseKernelBody dec stms res =+ let Body dec' _ _ = mkWiseBody dec stms $ subExpsRes res_vs+ in KernelBody dec' stms res where res_vs = map kernelResultSubExp res
src/Futhark/Internalise/AccurateSizes.hs view
@@ -42,20 +42,13 @@ match (Var v, se) = Just (v, se) match _ = Nothing -argShapes ::- (HasScope SOACS m, Monad m) =>- [VName] ->- [FParam] ->- [Type] ->- m [SubExp]+argShapes :: [VName] -> [FParam] -> [Type] -> InternaliseM [SubExp] argShapes shapes all_params valargts = do mapping <- shapeMapping all_params valargts let addShape name = case M.lookup name mapping of Just se -> se- _ -> intConst Int64 0 -- FIXME: we only need this because- -- the defunctionaliser throws away- -- sizes.+ _ -> error $ "argShapes: " ++ pretty name return $ map addShape shapes ensureResultShape ::
src/Futhark/Internalise/Exps.hs view
@@ -431,19 +431,18 @@ sparams' = map (`TypeParamDim` mempty) sparams forLoop mergepat' shapepat mergeinit form' =- bodyFromStms $- inScopeOf form' $ do- ses <- internaliseExp "loopres" loopbody- sets <- mapM subExpType ses- shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets- return- ( subExpsRes $ shapeargs ++ ses,- ( form',- shapepat,- mergepat',- mergeinit- )+ bodyFromStms . inScopeOf form' $ do+ ses <- internaliseExp "loopres" loopbody+ sets <- mapM subExpType ses+ shapeargs <- argShapes (map I.paramName shapepat) mergepat' sets+ pure+ ( subExpsRes $ shapeargs ++ ses,+ ( form',+ shapepat,+ mergepat',+ mergeinit )+ ) handleForm mergeinit (E.ForIn x arr) = do arr' <- internaliseExpToVars "for_in_arr" arr@@ -453,17 +452,16 @@ i <- newVName "i" ts <- mapM subExpType mergeinit- bindingLoopParams sparams' mergepat ts $- \shapepat mergepat' ->- bindingLambdaParams [x] (map rowType arr_ts) $ \x_params -> do- let loopvars = zip x_params arr'- forLoop mergepat' shapepat mergeinit $- I.ForLoop i Int64 w loopvars+ bindingLoopParams sparams' mergepat ts $ \shapepat mergepat' ->+ bindingLambdaParams [x] (map rowType arr_ts) $ \x_params -> do+ let loopvars = zip x_params arr'+ forLoop mergepat' shapepat mergeinit $+ I.ForLoop i Int64 w loopvars handleForm mergeinit (E.For i num_iterations) = do num_iterations' <- internaliseExp1 "upper_bound" num_iterations num_iterations_t <- I.subExpType num_iterations' it <- case num_iterations_t of- I.Prim (IntType it) -> return it+ I.Prim (IntType it) -> pure it _ -> error "internaliseExp DoLoop: invalid type" ts <- mapM subExpType mergeinit@@ -483,7 +481,7 @@ -- anything. shapeinit <- argShapes (map I.paramName shapepat) mergepat' mergeinit_ts - (loop_initial_cond, init_loop_cond_bnds) <- collectStms $ do+ (loop_initial_cond, init_loop_cond_stms) <- collectStms $ do forM_ (zip shapepat shapeinit) $ \(p, se) -> letBindNames [paramName p] $ BasicOp $ SubExp se forM_ (zip mergepat' mergeinit) $ \(p, se) ->@@ -497,7 +495,7 @@ _ -> SubExp se internaliseExp1 "loop_cond" cond - addStms init_loop_cond_bnds+ addStms init_loop_cond_stms bodyFromStms $ do ses <- internaliseExp "loopres" loopbody@@ -522,7 +520,7 @@ subExpsRes <$> internaliseExp "loop_cond" cond loop_end_cond <- bodyBind loop_end_cond_body - return+ pure ( subExpsRes shapeargs ++ loop_end_cond ++ subExpsRes ses, ( I.WhileLoop $ I.paramName loop_while, shapepat,@@ -567,9 +565,8 @@ internaliseExp desc (E.QualParens _ e _) = internaliseExp desc e internaliseExp desc (E.StringLit vs _) =- fmap pure $- letSubExp desc $- I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8+ fmap pure . letSubExp desc $+ I.BasicOp $ I.ArrayLit (map constant vs) $ I.Prim int8 internaliseExp _ (E.Var (E.QualName _ name) _ _) = do subst <- lookupSubst name case subst of@@ -1213,9 +1210,8 @@ I.BasicOp $ I.SubExp $ constant (0 :: Int64) forM_ lam_val_params $ \p -> letBindNames [I.paramName p] $- I.BasicOp $- I.Scratch (I.elemType $ I.paramType p) $- I.arrayDims $ I.paramType p+ I.BasicOp . I.Scratch (I.elemType $ I.paramType p) $+ I.arrayDims $ I.paramType p nes <- bodyBind =<< renameBody lam_body nes_ts <- mapM I.subExpResType nes@@ -1348,9 +1344,8 @@ InternaliseM a certifyingNonnegative loc t x m = do nonnegative <-- letSubExp "nonnegative" $- I.BasicOp $- CmpOp (CmpSle t) (intConst t 0) x+ letSubExp "nonnegative" . I.BasicOp $+ CmpOp (CmpSle t) (intConst t 0) x c <- assert "nonzero_cert" nonnegative "negative exponent" loc certifying c m
src/Futhark/Internalise/Monad.hs view
@@ -86,7 +86,7 @@ instance MonadBuilder InternaliseM where type Rep InternaliseM = SOACS mkExpDecM pat e = InternaliseM $ mkExpDecM pat e- mkBodyM bnds res = InternaliseM $ mkBodyM bnds res+ mkBodyM stms res = InternaliseM $ mkBodyM stms res mkLetNamesM pat e = InternaliseM $ mkLetNamesM pat e addStms = InternaliseM . addStms
src/Futhark/Optimise/CSE.hs view
@@ -328,9 +328,9 @@ (ASTRep rep, Aliased rep, CSEInOp (Op rep)) => GPU.KernelBody rep -> CSEM rep (GPU.KernelBody rep)-cseInKernelBody (GPU.KernelBody bodydec bnds res) = do- Body _ bnds' _ <- cseInBody (map (const Observe) res) $ Body bodydec bnds []- return $ GPU.KernelBody bodydec bnds' res+cseInKernelBody (GPU.KernelBody bodydec stms res) = do+ Body _ stms' _ <- cseInBody (map (const Observe) res) $ Body bodydec stms []+ return $ GPU.KernelBody bodydec stms' res instance CSEInOp op => CSEInOp (Memory.MemOp op) where cseInOp o@Memory.Alloc {} = return o
src/Futhark/Optimise/DoubleBuffer.hs view
@@ -463,10 +463,10 @@ -- based on the type of the function parameter. let t = resultType $ paramType fparam summary = MemArray (elemType t) (arrayShape t) NoUniqueness $ ArrayIn bufname ixfun- copybnd =+ copystm = Let (Pat [PatElem copyname summary]) (defAux ()) $ BasicOp $ Copy v- in (Just copybnd, SubExpRes cs (Var copyname))+ in (Just copystm, SubExpRes cs (Var copyname)) buffer _ _ se = (Nothing, se)
src/Futhark/Optimise/Fusion.hs view
@@ -328,8 +328,8 @@ expandSoacInpArr = foldM ( \y nm -> do- bnd <- asks $ M.lookup nm . soacs- case bnd of+ stm <- asks $ M.lookup nm . soacs+ case stm of Nothing -> return (y ++ [nm]) Just nns -> return (y ++ nns) )@@ -388,7 +388,7 @@ return $ inputs' `SOAC.setInputs` soac -- | Attempts to fuse between SOACs. Input:--- @rem_bnds@ are the bindings remaining in the current body after @orig_soac@.+-- @rem_stms@ are the bindings remaining in the current body after @orig_soac@. -- @lam_used_nms@ the infusible names -- @res@ the fusion result (before processing the current soac) -- @orig_soac@ and @out_idds@ the current SOAC and its binding pattern@@ -400,7 +400,7 @@ FusedRes -> (Pat, StmAux (), SOAC, Names) -> FusionGM FusedRes-greedyFuse rem_bnds lam_used_nms res (out_idds, aux, orig_soac, consumed) = do+greedyFuse rem_stms lam_used_nms res (out_idds, aux, orig_soac, consumed) = do soac <- inlineSOACInputs orig_soac (inp_nms, other_nms) <- soacInputs soac -- Assumption: the free vars in lambda are already in @infusible res@.@@ -421,7 +421,7 @@ (ok_kers_compat, fused_kers, fused_nms, old_kers, oldker_nms) <- if is_screma || any isInfusible out_nms- then horizontGreedyFuse rem_bnds res (out_idds, aux, soac, consumed)+ then horizontGreedyFuse rem_stms res (out_idds, aux, soac, consumed) else prodconsGreedyFuse res (out_idds, aux, soac, consumed) -- -- (ii) check whether fusing @soac@ will violate any in-place update@@ -529,7 +529,7 @@ FusedRes -> (Pat, StmAux (), SOAC, Names) -> FusionGM (Bool, [FusedKer], [KernName], [FusedKer], [KernName])-horizontGreedyFuse rem_bnds res (out_idds, aux, soac, consumed) = do+horizontGreedyFuse rem_stms res (out_idds, aux, soac, consumed) = do (inp_nms, _) <- soacInputs soac let out_nms = patNames out_idds infusible_nms = namesFromList $ filter (`nameIn` infusible res) out_nms@@ -555,10 +555,10 @@ -- located and sort based on the index so that partial fusion may -- succeed. We use the last position where one of the kernel -- outputs occur.- let bnd_nms = map (patNames . stmPat) rem_bnds+ let stm_nms = map (patNames . stmPat) rem_stms kernminds <- forM to_fuse_knms $ \ker_nm -> do ker <- lookupKernel ker_nm- case mapMaybe (\out_nm -> L.findIndex (elem out_nm) bnd_nms) (outNames ker) of+ case mapMaybe (\out_nm -> L.findIndex (elem out_nm) stm_nms) (outNames ker) of [] -> return Nothing is -> return $ Just (ker, ker_nm, maxinum is) @@ -570,7 +570,7 @@ -- kernel until which fusion succeded, and @fused_ker@ is the resulting kernel. (_, ok_ind, _, fused_ker, _) <- foldM- ( \(cur_ok, n, prev_ind, cur_ker, ufus_nms) (ker, _ker_nm, bnd_ind) -> do+ ( \(cur_ok, n, prev_ind, cur_ker, ufus_nms) (ker, _ker_nm, stm_ind) -> do -- check that we still try fusion and that the intermediate -- bindings do not use the results of cur_ker let curker_outnms = outNames cur_ker@@ -596,12 +596,12 @@ curker_outset `namesIntersect` freeIn (lambdaBody $ SOAC.lambda $ fsoac ker) - let interm_bnds_ok =+ let interm_stms_ok = cur_ok && consumer_ok && out_transf_ok && cons_no_out_transf && foldl- ( \ok bnd ->+ ( \ok stm -> ok- && not (curker_outset `namesIntersect` freeIn (stmExp bnd))+ && not (curker_outset `namesIntersect` freeIn (stmExp stm)) -- hardwired to False after first fail -- (i) check that the in-between bindings do -- not use the result of current kernel OR@@ -614,13 +614,13 @@ not ( null $ curker_outnms- `L.intersect` patNames (stmPat bnd)+ `L.intersect` patNames (stmPat stm) ) ) True- (drop (prev_ind + 1) $ take bnd_ind rem_bnds)- if not interm_bnds_ok- then return (False, n, bnd_ind, cur_ker, mempty)+ (drop (prev_ind + 1) $ take stm_ind rem_stms)+ if not interm_stms_ok+ then return (False, n, stm_ind, cur_ker, mempty) else do new_ker <- attemptFusion@@ -630,10 +630,10 @@ (fusedConsumed cur_ker) ker case new_ker of- Nothing -> return (False, n, bnd_ind, cur_ker, mempty)+ Nothing -> return (False, n, stm_ind, cur_ker, mempty) Just krn -> let krn' = krn {kerAux = aux <> kerAux krn}- in return (True, n + 1, bnd_ind, krn', new_ufus_nms)+ in return (True, n + 1, stm_ind, krn', new_ufus_nms) ) (True, 0, 0, soac_kernel, infusible_nms) kernminds'@@ -681,7 +681,7 @@ -- be considered a stream, to avoid infinite recursion. fusionGatherStms fres- (Let (Pat pes) bndtp (DoLoop merge (ForLoop i it w loop_vars) body) : bnds)+ (Let (Pat pes) stmtp (DoLoop merge (ForLoop i it w loop_vars) body) : stms) res | not $ null loop_vars = do let (merge_params, merge_init) = unzip merge@@ -735,9 +735,9 @@ fusionGatherStms fres- (Let (Pat (pes <> [discard_pe])) bndtp (Op stream) : bnds)+ (Let (Pat (pes <> [discard_pe])) stmtp (Op stream) : stms) res-fusionGatherStms fres (bnd@(Let pat _ e) : bnds) res = do+fusionGatherStms fres (stm@(Let pat _ e) : stms) res = do maybesoac <- SOAC.fromExp e case maybesoac of Right soac@(SOAC.Scatter _len lam _ivs _as) -> do@@ -758,9 +758,9 @@ concatMap scanNeutral scans <> concatMap redNeutral reds Right soac@(SOAC.Stream _ form lam nes _) -> do -- a redomap does not neccessarily start a new kernel, e.g.,- -- @let a= reduce(+,0,A) in ... bnds ... in let B = map(f,A)@+ -- @let a= reduce(+,0,A) in ... stms ... in let B = map(f,A)@ -- can be fused into a redomap that replaces the @map@, if @a@- -- and @B@ are defined in the same scope and @bnds@ does not uses @a@.+ -- and @B@ are defined in the same scope and @stms@ does not uses @a@. -- a redomap always starts a new kernel let lambdas = case form of Parallel _ _ lout -> [lout, lam]@@ -768,30 +768,30 @@ reduceLike soac lambdas nes _ | Pat [pe] <- pat,- Just (src, trns) <- SOAC.transformFromExp (stmCerts bnd) e ->- bindingTransform pe src trns $ fusionGatherStms fres bnds res+ Just (src, trns) <- SOAC.transformFromExp (stmCerts stm) e ->+ bindingTransform pe src trns $ fusionGatherStms fres stms res | otherwise -> do let pat_vars = map (BasicOp . SubExp . Var) $ patNames pat- bres <- gatherStmPat pat e $ fusionGatherStms fres bnds res+ bres <- gatherStmPat pat e $ fusionGatherStms fres stms res bres' <- checkForUpdates bres e foldM fusionGatherExp bres' (e : pat_vars) where- aux = stmAux bnd- rem_bnds = bnd : bnds+ aux = stmAux stm+ rem_stms = stm : stms consumed = consumedInExp $ Alias.analyseExp mempty e reduceLike soac lambdas nes = do (used_lam, lres) <- foldM fusionGatherLam (mempty, fres) lambdas- bres <- bindingFamily pat $ fusionGatherStms lres bnds res+ bres <- bindingFamily pat $ fusionGatherStms lres stms res bres' <- foldM fusionGatherSubExp bres nes consumed' <- varsAliases consumed- greedyFuse rem_bnds used_lam bres' (pat, aux, soac, consumed')+ greedyFuse rem_stms used_lam bres' (pat, aux, soac, consumed') mapLike fres' soac lambda = do- bres <- bindingFamily pat $ fusionGatherStms fres' bnds res+ bres <- bindingFamily pat $ fusionGatherStms fres' stms res (used_lam, blres) <- fusionGatherLam (mempty, bres) lambda consumed' <- varsAliases consumed- greedyFuse rem_bnds used_lam blres (pat, aux, soac, consumed')+ greedyFuse rem_stms used_lam blres (pat, aux, soac, consumed') fusionGatherStms fres [] res = foldM fusionGatherExp fres $ map (BasicOp . SubExp . resSubExp) res @@ -860,8 +860,8 @@ -- cannot be fused from outside the lambda: let inp_arrs = namesFromList $ M.keys $ inpArr new_res let unfus = infusible new_res <> inp_arrs- bnds <- asks $ M.keys . varsInScope- let unfus' = unfus `namesIntersection` namesFromList bnds+ stms <- asks $ M.keys . varsInScope+ let unfus' = unfus `namesIntersection` namesFromList stms -- merge fres with new_res' let new_res' = new_res {infusible = unfus'} -- merge new_res with fres'@@ -877,8 +877,8 @@ fuseInStms stms | Just (Let pat aux e, stms') <- stmsHead stms = do stms'' <- bindingPat pat $ fuseInStms stms'- soac_bnds <- replaceSOAC pat aux e- pure $ soac_bnds <> stms''+ soac_stms <- replaceSOAC pat aux e+ pure $ soac_stms <> stms'' | otherwise = pure mempty @@ -1038,23 +1038,23 @@ let free_consumed = consumedByLambda lam `namesSubtract` namesFromList (map paramName $ lambdaParams lam)- (bnds, subst) <-+ (stms, subst) <- foldM copyFree (mempty, mempty) $ namesToList free_consumed let lam' = Aliases.removeLambdaAliases lam return $- if null bnds+ if null stms then lam' else lam' { lambdaBody =- insertStms bnds $+ insertStms stms $ substituteNames subst $ lambdaBody lam' } - copyFree (bnds, subst) v = do+ copyFree (stms, subst) v = do v_copy <- newVName $ baseString v <> "_copy" copy <- mkLetNamesM [v_copy] $ BasicOp $ Copy v- return (oneStm copy <> bnds, M.insert v v_copy subst)+ return (oneStm copy <> stms, M.insert v v_copy subst) --------------------------------------------------- ---------------------------------------------------
src/Futhark/Optimise/Fusion/Composing.hs view
@@ -75,12 +75,12 @@ lambdaBody = new_body2' } new_body2 =- let bnds res =+ let stms res = [ certify cs $ mkLet [p] $ BasicOp $ SubExp e | (p, SubExpRes cs e) <- zip pat res ] bindLambda res =- stmsFromList (bnds res) `insertStms` makeCopiesInner (lambdaBody lam2)+ stmsFromList (stms res) `insertStms` makeCopiesInner (lambdaBody lam2) in makeCopies $ mapResult bindLambda (lambdaBody lam1) new_body2_rses = bodyResult new_body2 new_body2' =@@ -107,7 +107,7 @@ Body rep -> Body rep ) fuseInputs unfus_nms lam1 inp1 out1 lam2 inp2 =- (lam2redparams, unfus_vars, outbnds, inputmap, makeCopies, makeCopiesInner)+ (lam2redparams, unfus_vars, outstms, inputmap, makeCopies, makeCopiesInner) where (lam2redparams, lam2arrparams) = splitAt (length lam2params - length inp2) lam2params@@ -120,7 +120,7 @@ outins = uncurry (outParams $ map fst out1) $ unzip $ M.toList lam2inputmap'- outbnds = filterOutParams out1 outins+ outstms = filterOutParams out1 outins (inputmap, makeCopies) = removeDuplicateInputs $ originputmap `M.difference` outins -- Cosmin: @unfus_vars@ is supposed to be the lam2 vars corresponding to unfus_nms (?)
src/Futhark/Optimise/InPlaceLowering.hs view
@@ -125,9 +125,9 @@ Constraints rep => Body (Aliases rep) -> ForwardingM rep (Body (Aliases rep))-optimiseBody (Body als bnds res) = do- bnds' <- deepen $ optimiseStms (stmsToList bnds) $ mapM_ (seen . resSubExp) res- return $ Body als (stmsFromList bnds') res+optimiseBody (Body als stms res) = do+ stms' <- deepen $ optimiseStms (stmsToList stms) $ mapM_ (seen . resSubExp) res+ return $ Body als (stmsFromList stms') res where seen Constant {} = return () seen (Var v) = seenVar v@@ -138,18 +138,18 @@ ForwardingM rep () -> ForwardingM rep [Stm (Aliases rep)] optimiseStms [] m = m >> return []-optimiseStms (bnd : bnds) m = do- (bnds', bup) <- tapBottomUp $ bindingStm bnd $ optimiseStms bnds m- bnd' <- optimiseInStm bnd+optimiseStms (stm : stms) m = do+ (stms', bup) <- tapBottomUp $ bindingStm stm $ optimiseStms stms m+ stm' <- optimiseInStm stm case filter ((`elem` boundHere) . updateValue) $ forwardThese bup of [] -> do- checkIfForwardableUpdate bnd'- return $ bnd' : bnds'+ checkIfForwardableUpdate stm'+ return $ stm' : stms' updates -> do lower <- asks topLowerUpdate scope <- askScope - -- If we forward any updates, we need to remove them from bnds'.+ -- If we forward any updates, we need to remove them from stms'. let updated_names = map updateName updates notUpdated =@@ -157,18 +157,18 @@ -- Condition (5) and (7) are assumed to be checked by -- lowerUpdate.- case lower scope bnd' updates of+ case lower scope stm' updates of Just lowering -> do- new_bnds <- lowering- new_bnds' <-- optimiseStms new_bnds $+ new_stms <- lowering+ new_stms' <-+ optimiseStms new_stms $ tell bup {forwardThese = []}- return $ new_bnds' ++ filter notUpdated bnds'+ return $ new_stms' ++ filter notUpdated stms' Nothing -> do- checkIfForwardableUpdate bnd'- return $ bnd' : bnds'+ checkIfForwardableUpdate stm'+ return $ stm' : stms' where- boundHere = patNames $ stmPat bnd+ boundHere = patNames $ stmPat stm checkIfForwardableUpdate (Let pat (StmAux cs _ _) e) | Pat [PatElem v dec] <- pat,
src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs view
@@ -54,13 +54,13 @@ lowerUpdate scope (Let pat aux (DoLoop merge form body)) updates = do canDo <- lowerUpdateIntoLoop scope updates pat merge form body Just $ do- (prebnds, postbnds, pat', merge', body') <- canDo+ (prestms, poststms, pat', merge', body') <- canDo return $- prebnds+ prestms ++ [ certify (stmAuxCerts aux) $ mkLet pat' $ DoLoop merge' form body' ]- ++ postbnds+ ++ poststms lowerUpdate _ (Let pat aux (BasicOp (SubExp (Var v))))@@ -153,13 +153,16 @@ let res_dims = arrayDims $ snd bindee_dec ret' = WriteReturns cs (Shape res_dims) src [(Slice $ map DimFix slice', se)] + v_aliased <- newName v+ return ( PatElem bindee_nm bindee_dec, bodystms, ret',- oneStm $- mkLet [Ident v $ typeOf v_dec] $- BasicOp $ Index bindee_nm slice+ stmsFromList+ [ mkLet [Ident v_aliased $ typeOf v_dec] $ BasicOp $ Index bindee_nm slice,+ mkLet [Ident v $ typeOf v_dec] $ BasicOp $ Copy v_aliased+ ] ) onRet pe ret = Just $ return (pe, mempty, ret, mempty)@@ -221,13 +224,13 @@ Just $ do in_place_map <- mk_in_place_map- (val', prebnds, postbnds) <- mkMerges in_place_map+ (val', prestms, poststms) <- mkMerges in_place_map let valpat = mkResAndPat in_place_map idxsubsts = indexSubstitutions in_place_map- (idxsubsts', newbnds) <- substituteIndices idxsubsts $ bodyStms body- (body_res, res_bnds) <- manipulateResult in_place_map idxsubsts'- let body' = mkBody (newbnds <> res_bnds) body_res- return (prebnds, postbnds, valpat, val', body')+ (idxsubsts', newstms) <- substituteIndices idxsubsts $ bodyStms body+ (body_res, res_stms) <- manipulateResult in_place_map idxsubsts'+ let body' = mkBody (newstms <> res_stms) body_res+ return (prestms, poststms, valpat, val', body') where usedInBody = mconcat $ map (`lookupAliases` scope) $ namesToList $ freeIn body <> freeIn form@@ -238,9 +241,9 @@ [LoopResultSummary (als, Type)] -> m ([(Param DeclType, SubExp)], [Stm rep], [Stm rep]) mkMerges summaries = do- ((origmerge, extramerge), (prebnds, postbnds)) <-+ ((origmerge, extramerge), (prestms, poststms)) <- runWriterT $ partitionEithers <$> mapM mkMerge summaries- return (origmerge ++ extramerge, prebnds, postbnds)+ return (origmerge ++ extramerge, prestms, poststms) mkMerge summary | Just (update, mergename, mergedec) <- relatedUpdate summary = do@@ -335,25 +338,23 @@ } deriving (Show) -indexSubstitutions ::- [LoopResultSummary dec] ->- IndexSubstitutions dec+indexSubstitutions :: Typed dec => [LoopResultSummary dec] -> IndexSubstitutions indexSubstitutions = mapMaybe getSubstitution where getSubstitution res = do (DesiredUpdate _ _ cs _ is _, nm, dec) <- relatedUpdate res let name = paramName $ fst $ mergeParam res- return (name, (cs, nm, dec, is))+ return (name, (cs, nm, typeOf dec, is)) manipulateResult :: (Buildable rep, MonadFreshNames m) => [LoopResultSummary (LetDec rep)] ->- IndexSubstitutions (LetDec rep) ->+ IndexSubstitutions -> m (Result, Stms rep) manipulateResult summaries substs = do let (orig_ses, updated_ses) = partitionEithers $ map unchangedRes summaries- (subst_ses, res_bnds) <- runWriterT $ zipWithM substRes updated_ses substs- pure (orig_ses ++ subst_ses, stmsFromList res_bnds)+ (subst_ses, res_stms) <- runWriterT $ zipWithM substRes updated_ses substs+ pure (orig_ses ++ subst_ses, stmsFromList res_stms) where unchangedRes summary = case relatedUpdate summary of
src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs view
@@ -18,20 +18,16 @@ import Futhark.IR import Futhark.IR.Prop.Aliases import Futhark.Transform.Substitute-import Futhark.Util -type IndexSubstitution dec = (Certs, VName, dec, Slice SubExp)+type IndexSubstitution = (Certs, VName, Type, Slice SubExp) -type IndexSubstitutions dec = [(VName, IndexSubstitution dec)]+type IndexSubstitutions = [(VName, IndexSubstitution)] -typeEnvFromSubstitutions ::- LetDec rep ~ dec =>- IndexSubstitutions dec ->- Scope rep+typeEnvFromSubstitutions :: LParamInfo rep ~ Type => IndexSubstitutions -> Scope rep typeEnvFromSubstitutions = M.fromList . map (fromSubstitution . snd) where fromSubstitution (_, name, t, _) =- (name, LetName t)+ (name, LParamName t) -- | Perform the substitution. substituteIndices ::@@ -39,52 +35,58 @@ BuilderOps rep, Buildable rep, Aliased rep,- LetDec rep ~ dec+ LParamInfo rep ~ Type ) =>- IndexSubstitutions dec ->+ IndexSubstitutions -> Stms rep ->- m (IndexSubstitutions dec, Stms rep)-substituteIndices substs bnds =- runBuilderT (substituteIndicesInStms substs bnds) types+ m (IndexSubstitutions, Stms rep)+substituteIndices substs stms =+ runBuilderT (substituteIndicesInStms substs stms) types where types = typeEnvFromSubstitutions substs substituteIndicesInStms :: (MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) =>- IndexSubstitutions (LetDec (Rep m)) ->+ IndexSubstitutions -> Stms (Rep m) ->- m (IndexSubstitutions (LetDec (Rep m)))+ m IndexSubstitutions substituteIndicesInStms = foldM substituteIndicesInStm substituteIndicesInStm :: (MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) =>- IndexSubstitutions (LetDec (Rep m)) ->+ IndexSubstitutions -> Stm (Rep m) ->- m (IndexSubstitutions (LetDec (Rep m)))+ m IndexSubstitutions+-- FIXME: we likely need to do something similar for all expressions+-- that produce aliases. Ugh. See issue #1460. Or maybe we should+-- look at/copy all consumed arrays up front, instead of ad-hoc.+substituteIndicesInStm substs (Let pat _ (BasicOp (Rotate rots v)))+ | Just (cs, src, src_t, is) <- lookup v substs,+ [v'] <- patNames pat = do+ src' <-+ letExp (baseString v' <> "_subst") $+ BasicOp $ Rotate (replicate (arrayRank src_t - length rots) zero ++ rots) src+ src_t' <- lookupType src'+ pure $ (v', (cs, src', src_t', is)) : substs+ where+ zero = intConst Int64 0+substituteIndicesInStm substs (Let pat _ (BasicOp (Rearrange perm v)))+ | Just (cs, src, src_t, is) <- lookup v substs,+ [v'] <- patNames pat = do+ let extra_dims = arrayRank src_t - length perm+ perm' = [0 .. extra_dims -1] ++ map (+ extra_dims) perm+ src' <-+ letExp (baseString v' <> "_subst") $ BasicOp $ Rearrange perm' src+ src_t' <- lookupType src'+ pure $ (v', (cs, src', src_t', is)) : substs substituteIndicesInStm substs (Let pat rep e) = do e' <- substituteIndicesInExp substs e- (substs', pat') <- substituteIndicesInPat substs pat- addStm $ Let pat' rep e'- return substs'--substituteIndicesInPat ::- (MonadBuilder m, LetDec (Rep m) ~ dec) =>- IndexSubstitutions (LetDec (Rep m)) ->- PatT dec ->- m (IndexSubstitutions (LetDec (Rep m)), PatT dec)-substituteIndicesInPat substs pat = do- (substs', pes) <- mapAccumLM sub substs $ patElems pat- return (substs', Pat pes)- where- sub substs' patElem = return (substs', patElem)+ addStm $ Let pat rep e'+ pure substs substituteIndicesInExp ::- ( MonadBuilder m,- Buildable (Rep m),- Aliased (Rep m),- LetDec (Rep m) ~ dec- ) =>- IndexSubstitutions (LetDec (Rep m)) ->+ (MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) =>+ IndexSubstitutions -> Exp (Rep m) -> m (Exp (Rep m)) substituteIndicesInExp substs (Op op) = do@@ -93,7 +95,8 @@ forM used_in_op $ \(v, (cs, src, src_dec, Slice is)) -> do v' <- certifying cs $- letExp "idx" $ BasicOp $ Index src $ fullSlice (typeOf src_dec) is+ letExp (baseString src <> "_op_idx") $+ BasicOp $ Index src $ fullSlice (typeOf src_dec) is pure $ M.singleton v v' pure $ Op $ substituteNames var_substs op substituteIndicesInExp substs e = do@@ -135,7 +138,7 @@ substituteIndicesInSubExp :: MonadBuilder m =>- IndexSubstitutions (LetDec (Rep m)) ->+ IndexSubstitutions -> SubExp -> m SubExp substituteIndicesInSubExp substs (Var v) =@@ -145,7 +148,7 @@ substituteIndicesInVar :: MonadBuilder m =>- IndexSubstitutions (LetDec (Rep m)) ->+ IndexSubstitutions -> VName -> m VName substituteIndicesInVar substs v@@ -154,13 +157,14 @@ letExp (baseString src2) $ BasicOp $ SubExp $ Var src2 | Just (cs2, src2, src2_dec, Slice is2) <- lookup v substs = certifying cs2 $- letExp "idx" $ BasicOp $ Index src2 $ fullSlice (typeOf src2_dec) is2+ letExp (baseString src2 <> "_v_idx") $+ BasicOp $ Index src2 $ fullSlice (typeOf src2_dec) is2 | otherwise = return v substituteIndicesInBody :: (MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) =>- IndexSubstitutions (LetDec (Rep m)) ->+ IndexSubstitutions -> Body (Rep m) -> m (Body (Rep m)) substituteIndicesInBody substs (Body _ stms res) = do@@ -178,9 +182,9 @@ update :: VName -> VName ->- IndexSubstitution dec ->- IndexSubstitutions dec ->- IndexSubstitutions dec+ IndexSubstitution ->+ IndexSubstitutions ->+ IndexSubstitutions update needle name subst ((othername, othersubst) : substs) | needle == othername = (name, subst) : substs | otherwise = (othername, othersubst) : update needle name subst substs
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -142,7 +142,7 @@ SimpleOps mkExpDecS' mkBodyS' protectHoistedOpS' (const mempty) where mkExpDecS' _ pat e = return $ mkExpDec pat e- mkBodyS' _ bnds res = return $ mkBody bnds res+ mkBodyS' _ stms res = return $ mkBody stms res protectHoistedOpS' _ _ _ = Nothing newtype SimpleM rep a@@ -633,15 +633,15 @@ `orIf` isNotHoistableBnd rules <- asksEngineEnv envRules- (body1_bnds', safe1) <-+ (body1_stms', safe1) <- protectIfHoisted cond True $ hoistStms rules block vtable usages1 stms1- (body2_bnds', safe2) <-+ (body2_stms', safe2) <- protectIfHoisted cond False $ hoistStms rules block vtable usages2 stms2 let hoistable = safe1 <> safe2- body1' <- constructBody body1_bnds' res1- body2' <- constructBody body2_bnds' res2+ body1' <- constructBody body1_stms' res1+ body2' <- constructBody body2_stms' res2 return (body1', body2', hoistable) -- | Simplify a single body. The @[Diet]@ only covers the value@@ -651,8 +651,8 @@ [Diet] -> Body rep -> SimpleM rep (SimplifiedBody rep Result)-simplifyBody ds (Body _ bnds res) =- simplifyStms bnds $ do+simplifyBody ds (Body _ stms res) =+ simplifyStms stms $ do res' <- simplifyResult ds res return (res', mempty) @@ -662,7 +662,8 @@ SimplifiableRep rep => [Diet] -> Result -> SimpleM rep (Result, UT.UsageTable) simplifyResult ds res = do res' <- mapM simplify res- let consumption = consumeResult $ zip ds res'+ vtable <- askVtable+ let consumption = consumeResult vtable $ zip ds res' return (res', UT.usages (freeIn res') <> consumption) isDoLoopResult :: Result -> UT.UsageTable@@ -708,7 +709,7 @@ rules <- asksEngineEnv envRules simplified <- topDownSimplifyStm rules vtable stm case simplified of- Just newbnds -> changed >> inspectStms (newbnds <> stms') m+ Just newstms -> changed >> inspectStms (newstms <> stms') m Nothing -> do (x, stms'') <- localVtable (ST.insertStm stm) $ inspectStms stms' m return (x, oneStm stm <> stms'')@@ -880,8 +881,8 @@ instance Simplifiable SubExp where simplify (Var name) = do- bnd <- ST.lookupSubExp name <$> askVtable- case bnd of+ stm <- ST.lookupSubExp name <$> askVtable+ case stm of Just (Constant v, cs) -> do changed usedCerts cs@@ -985,11 +986,11 @@ rettype' <- simplify rettype return (Lambda params' body' rettype', hoisted) -consumeResult :: [(Diet, SubExpRes)] -> UT.UsageTable-consumeResult = mconcat . map inspect+consumeResult :: ST.SymbolTable rep -> [(Diet, SubExpRes)] -> UT.UsageTable+consumeResult vtable = mconcat . map inspect where- inspect (Consume, SubExpRes _ se) =- mconcat $ map UT.consumedUsage $ namesToList $ subExpAliases se+ inspect (Consume, SubExpRes _ (Var v)) =+ mconcat $ map UT.consumedUsage $ v : namesToList (ST.lookupAliases v vtable) inspect _ = mempty instance Simplifiable Certs where
src/Futhark/Optimise/Simplify/Rep.hs view
@@ -208,15 +208,15 @@ Stms (Wise rep) -> Result -> Body (Wise rep)-mkWiseBody dec bnds res =+mkWiseBody dec stms res = Body- ( BodyWisdom aliases consumed (AliasDec $ freeIn $ freeInStmsAndRes bnds res),+ ( BodyWisdom aliases consumed (AliasDec $ freeIn $ freeInStmsAndRes stms res), dec )- bnds+ stms res where- (aliases, consumed) = Aliases.mkBodyAliases bnds res+ (aliases, consumed) = Aliases.mkBodyAliases stms res mkWiseLetStm :: (ASTRep rep, CanBeWise (Op rep)) =>@@ -254,9 +254,9 @@ Let pat dec _ <- mkLetNames names $ removeExpWisdom e return $ mkWiseLetStm pat dec e - mkBody bnds res =- let Body bodyrep _ _ = mkBody (fmap removeStmWisdom bnds) res- in mkWiseBody bodyrep bnds res+ mkBody stms res =+ let Body bodyrep _ _ = mkBody (fmap removeStmWisdom stms) res+ in mkWiseBody bodyrep stms res class ( AliasedOp (OpWithWisdom op),
src/Futhark/Optimise/Simplify/Rule.hs view
@@ -75,7 +75,7 @@ instance (ASTRep rep, BuilderOps rep) => MonadBuilder (RuleM rep) where type Rep (RuleM rep) = rep mkExpDecM pat e = RuleM $ mkExpDecM pat e- mkBodyM bnds res = RuleM $ mkBodyM bnds res+ mkBodyM stms res = RuleM $ mkBodyM stms res mkLetNamesM pat e = RuleM $ mkLetNamesM pat e addStms = RuleM . addStms@@ -253,8 +253,8 @@ forOp RuleGeneric {} = True forOp _ = False --- | @simplifyStm lookup bnd@ performs simplification of the--- binding @bnd@. If simplification is possible, a replacement list+-- | @simplifyStm lookup stm@ performs simplification of the+-- binding @stm@. If simplification is possible, a replacement list -- of bindings is returned, that bind at least the same names as the -- original binding (and possibly more, for intermediate results). topDownSimplifyStm ::@@ -265,8 +265,8 @@ m (Maybe (Stms rep)) topDownSimplifyStm = applyRules . bookTopDownRules --- | @simplifyStm uses bnd@ performs simplification of the binding--- @bnd@. If simplification is possible, a replacement list of+-- | @simplifyStm uses stm@ performs simplification of the binding+-- @stm@. If simplification is possible, a replacement list of -- bindings is returned, that bind at least the same names as the -- original binding (and possibly more, for intermediate results). -- The first argument is the set of names used after this binding.
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -65,6 +65,11 @@ removeUnnecessaryCopy :: (BuilderOps rep, Aliased rep) => BottomUpRuleBasicOp rep removeUnnecessaryCopy (vtable, used) (Pat [d]) _ (Copy v) | not (v `UT.isConsumed` used),+ -- This next line is too conservative, but the problem is that 'v'+ -- might not look like it has been consumed if it is consumed in+ -- an outer scope. This is because the simplifier applies+ -- bottom-up rules in a kind of deepest-first order.+ not (patElemName d `UT.isInResult` used) || (patElemName d `UT.isConsumed` used), (not (v `UT.used` used) && consumable) || not (patElemName d `UT.isConsumed` used) = Simplify $ letBindNames [patElemName d] $ BasicOp $ SubExp $ Var v where
src/Futhark/Optimise/Simplify/Rules/BasicOp.hs view
@@ -206,10 +206,10 @@ | Just m <- simplifyWith se2 se1 = Simplify m where simplifyWith (Var v) x- | Just bnd <- ST.lookupStm v vtable,- If p tbranch fbranch _ <- stmExp bnd,+ | Just stm <- ST.lookupStm v vtable,+ If p tbranch fbranch _ <- stmExp stm, Just (y, z) <-- returns v (stmPat bnd) tbranch fbranch,+ returns v (stmPat stm) tbranch fbranch, not $ boundInBody tbranch `namesIntersect` freeIn y, not $ boundInBody fbranch `namesIntersect` freeIn z = Just $ do eq_x_y <-
src/Futhark/Optimise/Simplify/Rules/ClosedForm.hs view
@@ -130,19 +130,19 @@ [SubExp] -> RuleM rep (Body rep) checkResults pat size untouchable it knownBnds params body accs = do- ((), bnds) <-+ ((), stms) <- collectStms $ zipWithM_ checkResult (zip pat res) (zip accparams accs)- mkBodyM bnds $ varsRes pat+ mkBodyM stms $ varsRes pat where- bndMap = makeBindMap body+ stmMap = makeBindMap body (accparams, _) = splitAt (length accs) params res = bodyResult body nonFree = boundInBody body <> namesFromList params <> untouchable checkResult (p, SubExpRes _ (Var v)) (accparam, acc)- | Just (BasicOp (BinOp bop x y)) <- M.lookup v bndMap,+ | Just (BasicOp (BinOp bop x y)) <- M.lookup v stmMap, x /= y = do -- One of x,y must be *this* accumulator, and the other must -- be something that is free in the body.
src/Futhark/Optimise/Simplify/Rules/Index.hs view
@@ -190,13 +190,13 @@ letSubExp "index_concat" $ BasicOp $ Index x $ Slice $ ibef ++ DimFix i : iaft mkBranch ((x', start) : xs_and_starts') = do cmp <- letSubExp "index_concat_cmp" $ BasicOp $ CmpOp (CmpSle Int64) start i- (thisres, thisbnds) <- collectStms $ do+ (thisres, thisstms) <- collectStms $ do i' <- letSubExp "index_concat_i" $ BasicOp $ BinOp (Sub Int64 OverflowWrap) i start letSubExp "index_concat" . BasicOp . Index x' $ Slice $ ibef ++ DimFix i' : iaft- thisbody <- mkBodyM thisbnds [subExpRes thisres]- (altres, altbnds) <- collectStms $ mkBranch xs_and_starts'- altbody <- mkBodyM altbnds [subExpRes altres]+ thisbody <- mkBodyM thisstms [subExpRes thisres]+ (altres, altstms) <- collectStms $ mkBranch xs_and_starts'+ altbody <- mkBodyM altstms [subExpRes altres] letSubExp "index_concat_branch" $ If cmp thisbody altbody $ IfDec [primBodyType res_t] IfNormal
src/Futhark/Optimise/Simplify/Rules/Loop.hs view
@@ -122,9 +122,9 @@ isInvariant, -- Also do not remove the condition in a while-loop. not $ paramName mergeParam `nameIn` freeIn form =- let (bnd, explpat'') =+ let (stm, explpat'') = removeFromResult (mergeParam, mergeInit) explpat'- in ( maybe id (:) bnd $ (paramIdent mergeParam, mergeInit) : invariant,+ in ( maybe id (:) stm $ (paramIdent mergeParam, mergeInit) : invariant, explpat'', merge', resExps
src/Futhark/Optimise/TileLoops.hs view
@@ -46,11 +46,11 @@ optimiseStm stm@(Let pat aux (Op (SegOp (SegMap lvl@SegThread {} space ts kbody)))) = do res3dtiling <- doRegTiling3D stm case res3dtiling of- Just (extra_bnds, stmt') -> return (extra_bnds <> oneStm stmt')+ Just (extra_stms, stmt') -> return (extra_stms <> oneStm stmt') Nothing -> do blkRegTiling_res <- mmBlkRegTiling stm case blkRegTiling_res of- Just (extra_bnds, stmt') -> return (extra_bnds <> oneStm stmt')+ Just (extra_stms, stmt') -> return (extra_stms <> oneStm stmt') Nothing -> localScope (scopeOfSegSpace space) $ do (host_stms, (lvl', space', kbody')) <- tileInKernelBody mempty initial_variance lvl space ts kbody return $ host_stms <> oneStm (Let pat aux $ Op $ SegOp $ SegMap lvl' space' ts kbody')@@ -157,6 +157,7 @@ stms_res -- Tiling inside for-loop. | DoLoop merge (ForLoop i it bound []) loopbody <- stmExp stm_to_tile,+ not $ any ((`nameIn` freeIn merge) . paramName . fst) merge, (prestms', poststms') <- preludeToPostlude variance prestms stm_to_tile (stmsFromList poststms) = do let branch_variant' =
@@ -147,19 +147,19 @@ Nothing defVarianceInStm :: VarianceTable -> Stm GPU -> VarianceTable-defVarianceInStm variance bnd =- foldl' add variance $ patNames $ stmPat bnd+defVarianceInStm variance stm =+ foldl' add variance $ patNames $ stmPat stm where add variance' v = M.insert v binding_variance variance' look variance' v = oneName v <> M.findWithDefault mempty v variance'- binding_variance = mconcat $ map (look variance) $ namesToList (freeIn bnd)+ binding_variance = mconcat $ map (look variance) $ namesToList (freeIn stm) -- just in case you need the Screma being treated differently than -- by default; previously Cosmin had to enhance it when dealing with stream. varianceInStm :: VarianceTable -> Stm GPU -> VarianceTable-varianceInStm v0 bnd@(Let _ _ (Op (OtherOp Screma {})))- | Just (_, arrs, (_, red_lam, red_nes, map_lam)) <- isTileableRedomap bnd =- let v = defVarianceInStm v0 bnd+varianceInStm v0 stm@(Let _ _ (Op (OtherOp Screma {})))+ | Just (_, arrs, (_, red_lam, red_nes, map_lam)) <- isTileableRedomap stm =+ let v = defVarianceInStm v0 stm red_ps = lambdaParams red_lam map_ps = lambdaParams map_lam card_red = length red_nes@@ -177,7 +177,7 @@ foldl' f v $ zip4 arrs (map paramName map_ps) (map paramName acc_lam_f) (map paramName arr_lam_f) in varianceInStms v' stm_lam-varianceInStm v0 bnd = defVarianceInStm v0 bnd+varianceInStm v0 stm = defVarianceInStm v0 stm varianceInStms :: VarianceTable -> Stms GPU -> VarianceTable varianceInStms = foldl' varianceInStm
src/Futhark/Pass/ExpandAllocations.hs view
@@ -103,8 +103,8 @@ bodyStms b <> stmsFromList (zipWith bindRes (patElems pat) (bodyResult b)) transformStm (Let pat aux e) = do- (bnds, e') <- transformExp =<< mapExpM transform e- return $ bnds <> oneStm (Let pat aux e')+ (stms, e') <- transformExp =<< mapExpM transform e+ return $ stms <> oneStm (Let pat aux e') where transform = identityMapper@@ -501,9 +501,9 @@ -- We expand the invariant allocations by adding an inner dimension -- equal to the sum of the sizes required by different threads.- (alloc_bnds, rebases) <- unzip <$> mapM expand variant_allocs'+ (alloc_stms, rebases) <- unzip <$> mapM expand variant_allocs' - return (slice_stms' <> stmsFromList alloc_bnds, mconcat rebases)+ return (slice_stms' <> stmsFromList alloc_stms, mconcat rebases) where expand (mem, (offset, total_size, space)) = do let allocpat = Pat [PatElem mem $ MemMem space]
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -676,8 +676,8 @@ [Maybe Space] -> Body fromrep -> AllocM fromrep torep (Body torep, [FunReturns])-allocInFunBody space_oks (Body _ bnds res) =- buildBody . allocInStms bnds $ do+allocInFunBody space_oks (Body _ stms res) =+ buildBody . allocInStms stms $ do res' <- zipWithM ensureDirect space_oks' res (mem_ctx_res, mem_ctx_rets) <- unzip . concat <$> mapM bodyReturnMemCtx res' pure (mem_ctx_res <> res', mem_ctx_rets)@@ -738,12 +738,12 @@ (Allocable fromrep torep inner) => Exp fromrep -> AllocM fromrep torep (Exp torep)-allocInExp (DoLoop merge form (Body () bodybnds bodyres)) =+allocInExp (DoLoop merge form (Body () bodystms bodyres)) = allocInMergeParams merge $ \merge' mk_loop_val -> do form' <- allocInLoopForm form localScope (scopeOf form') $ do body' <-- buildBody_ . allocInStms bodybnds $ do+ buildBody_ . allocInStms bodystms $ do (val_ses, valres') <- mk_loop_val $ map resSubExp bodyres pure $ subExpsRes val_ses <> zipWith SubExpRes (map resCerts bodyres) valres' pure $ DoLoop merge' form' body'@@ -819,8 +819,8 @@ Int -> Body fromrep -> AllocM fromrep torep (Body torep, [Maybe IxFun])- allocInIfBody num_vals (Body _ bnds res) =- buildBody . allocInStms bnds $ do+ allocInIfBody num_vals (Body _ stms res) =+ buildBody . allocInStms stms $ do let (_, val_res) = splitFromEnd num_vals res mem_ixfs <- mapM (subExpIxFun . resSubExp) val_res pure (res, mem_ixfs)@@ -921,8 +921,8 @@ [Maybe Space] -> [Maybe (ExtIxFun, [TPrimExp Int64 VName])] -> AllocM fromrep torep (Body torep, [BodyReturns])-addResCtxInIfBody ifrets (Body _ bnds res) spaces substs = buildBody $ do- mapM_ addStm bnds+addResCtxInIfBody ifrets (Body _ stms res) spaces substs = buildBody $ do+ mapM_ addStm stms (ctx, ctx_rets, res', res_rets, total_existentials) <- foldM helper ([], [], [], [], 0) (zip4 ifrets res substs spaces) pure@@ -1107,7 +1107,7 @@ mkExpDecS' _ pat e = return $ Engine.mkWiseExpDec pat () e - mkBodyS' _ bnds res = return $ mkWiseBody () bnds res+ mkBodyS' _ stms res = return $ mkWiseBody () stms res protectOp taken pat (Alloc size space) = Just $ do tbody <- resultBodyM [size]
src/Futhark/Pass/ExtractKernels.hs view
@@ -21,7 +21,7 @@ -- @ -- map -- map(f)--- bnds_a...+-- stms_a... -- map(g) -- @ --@@ -31,7 +31,7 @@ -- map -- map(f) -- map--- bnds_a+-- stms_a -- map -- map(g) -- @@@ -40,7 +40,7 @@ -- -- (0) it can be done without creating irregular arrays. -- Specifically, the size of the arrays created by @map(f)@, by--- @map(g)@ and whatever is created by @bnds_a@ that is also used+-- @map(g)@ and whatever is created by @stms_a@ that is also used -- in @map(g)@, must be invariant to the outermost loop. -- -- (1) the maps are _balanced_. That is, the functions @f@ and @g@@@ -48,7 +48,7 @@ -- -- The advantage is that the map-nests containing @map(f)@ and -- @map(g)@ can now be trivially flattened at no cost, thus exposing--- more parallelism. Note that the @bnds_a@ map constitutes array+-- more parallelism. Note that the @stms_a@ map constitutes array -- expansion, which requires additional storage. -- -- = Distributing Sequential Loops@@ -249,20 +249,20 @@ transformBody :: KernelPath -> Body -> DistribM (Out.Body Out.GPU) transformBody path body = do- bnds <- transformStms path $ stmsToList $ bodyStms body- return $ mkBody bnds $ bodyResult body+ stms <- transformStms path $ stmsToList $ bodyStms body+ return $ mkBody stms $ bodyResult body transformStms :: KernelPath -> [Stm] -> DistribM GPUStms transformStms _ [] = return mempty-transformStms path (bnd : bnds) =- sequentialisedUnbalancedStm bnd >>= \case+transformStms path (stm : stms) =+ sequentialisedUnbalancedStm stm >>= \case Nothing -> do- bnd' <- transformStm path bnd- inScopeOf bnd' $- (bnd' <>) <$> transformStms path bnds- Just bnds' ->- transformStms path $ stmsToList bnds' <> bnds+ stm' <- transformStm path stm+ inScopeOf stm' $+ (stm' <>) <$> transformStms path stms+ Just stms' ->+ transformStms path $ stmsToList stms' <> stms unbalancedLambda :: Lambda -> Bool unbalancedLambda orig_lam =@@ -401,8 +401,8 @@ | otherwise = comm, Just do_irwim <- irwim res_pat w comm' red_fun $ zip nes arrs = do types <- asksScope scopeForSOACs- (_, bnds) <- fst <$> runBuilderT (simplifyStms =<< collectStms_ (auxing aux do_irwim)) types- transformStms path $ stmsToList bnds+ (_, stms) <- fst <$> runBuilderT (simplifyStms =<< collectStms_ (auxing aux do_irwim)) types+ transformStms path $ stmsToList stms transformStm path (Let pat aux@(StmAux cs _ _) (Op (Screma w arrs form))) | Just (reds, map_lam) <- isRedomapSOAC form = do let paralleliseOuter = runBuilder_ $ do@@ -578,8 +578,8 @@ addStms =<< histKernel onLambda lvl orig_pat [] [] cs w ops bfun' imgs where onLambda = pure . soacsLambdaToGPU-transformStm _ bnd =- runBuilder_ $ FOT.transformStmRecursively bnd+transformStm _ stm =+ runBuilder_ $ FOT.transformStmRecursively stm sufficientParallelism :: String ->@@ -915,12 +915,12 @@ -- sequentialising. This is only OK as long as further -- versioning does not take place down that branch (it currently -- does not).- (sequentialised_kernel, nestw_bnds) <- localScope extra_scope $ do+ (sequentialised_kernel, nestw_stms) <- localScope extra_scope $ do let sequentialised_lam = soacsLambdaToGPU lam' constructKernel segThreadCapped nest' $ lambdaBody sequentialised_lam let outer_pat = loopNestingPat $ fst nest- (nestw_bnds <>)+ (nestw_stms <>) <$> onMap' nest' path
src/Futhark/Pass/ExtractKernels/BlockedKernel.hs view
@@ -202,10 +202,10 @@ [KernelInput] -> m (SegSpace, Stms rep) mapKernelSkeleton ispace inputs = do- read_input_bnds <- runBuilder_ $ mapM readKernelInput inputs+ read_input_stms <- runBuilder_ $ mapM readKernelInput inputs space <- mkSegSpace ispace- return (space, read_input_bnds)+ return (space, read_input_stms) mapKernel :: (DistRep rep, HasScope rep m, MonadFreshNames m) =>
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -379,10 +379,10 @@ distributeIfPossible acc >>= \case Nothing -> addStmToAcc stm acc Just acc' -> distribute =<< onInnerMap (MapLoop pat (stmAux stm) w lam arrs) acc'-maybeDistributeStm bnd@(Let pat aux (DoLoop merge form@ForLoop {} body)) acc+maybeDistributeStm stm@(Let pat aux (DoLoop merge form@ForLoop {} body)) acc | not $ any (`nameIn` freeIn pat) $ patNames pat, bodyContainsParallelism body =- distributeSingleStm acc bnd >>= \case+ distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') | -- XXX: We cannot distribute if this loop depends on -- certificates bound within the loop nest (well, we could,@@ -411,7 +411,7 @@ onTopLevelStms stms return acc' _ ->- addStmToAcc bnd acc+ addStmToAcc stm acc maybeDistributeStm stm@(Let pat _ (If cond tbranch fbranch ret)) acc | not $ any (`nameIn` freeIn pat) $ patNames pat, bodyContainsParallelism tbranch || bodyContainsParallelism fbranch@@ -464,12 +464,12 @@ | Just [Reduce comm lam nes] <- isReduceSOAC form, Just m <- irwim pat w comm lam $ zip nes arrs = do types <- asksScope scopeForSOACs- (_, bnds) <- runBuilderT (auxing aux m) types- distributeMapBodyStms acc bnds+ (_, stms) <- runBuilderT (auxing aux m) types+ distributeMapBodyStms acc stms -- Parallelise segmented scatters.-maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Scatter w lam ivs as))) acc =- distributeSingleStm acc bnd >>= \case+maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Scatter w lam ivs as))) acc =+ distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> localScope (typeEnvFromDistAcc acc') $ do@@ -479,10 +479,10 @@ postStm =<< segmentedScatterKernel nest' perm pat cs w lam' ivs as return acc' _ ->- addStmToAcc bnd acc+ addStmToAcc stm acc -- Parallelise segmented Hist.-maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Hist w ops lam as))) acc =- distributeSingleStm acc bnd >>= \case+maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Hist w ops lam as))) acc =+ distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> localScope (typeEnvFromDistAcc acc') $ do@@ -492,7 +492,7 @@ postStm =<< segmentedHistKernel nest' perm cs w ops lam' as return acc' _ ->- addStmToAcc bnd acc+ addStmToAcc stm acc -- Parallelise Index slices if the result is going to be returned -- directly from the kernel. This is because we would otherwise have -- to sequentialise writing the result, which may be costly.@@ -512,10 +512,10 @@ -- -- If the scan cannot be distributed by itself, it will be -- sequentialised in the default case for this function.-maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc+maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc | Just (scans, map_lam) <- isScanomapSOAC form, Scan lam nes <- singleScan scans =- distributeSingleStm acc bnd >>= \case+ distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> -- We need to pretend pat_unused was used anyway, by adding@@ -526,18 +526,18 @@ lam' <- soacsLambda lam localScope (typeEnvFromDistAcc acc') $ segmentedScanomapKernel nest' perm w lam' map_lam' nes arrs- >>= kernelOrNot cs bnd acc kernels acc'+ >>= kernelOrNot cs stm acc kernels acc' _ ->- addStmToAcc bnd acc+ addStmToAcc stm acc -- if the reduction can be distributed by itself, we will turn it into a -- segmented reduce. -- -- If the reduction cannot be distributed by itself, it will be -- sequentialised in the default case for this function.-maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc+maybeDistributeStm stm@(Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc | Just (reds, map_lam) <- isRedomapSOAC form, Reduce comm lam nes <- singleReduce reds =- distributeSingleStm acc bnd >>= \case+ distributeSingleStm acc stm >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> -- We need to pretend pat_unused was used anyway, by adding@@ -553,9 +553,9 @@ | otherwise = comm regularSegmentedRedomapKernel nest' perm w comm' lam' map_lam' nes arrs- >>= kernelOrNot cs bnd acc kernels acc'+ >>= kernelOrNot cs stm acc kernels acc' _ ->- addStmToAcc bnd acc+ addStmToAcc stm acc maybeDistributeStm (Let pat (StmAux cs _ _) (Op (Screma w arrs form))) acc = do -- This Screma is too complicated for us to immediately do -- anything, so split it up and try again.@@ -566,16 +566,16 @@ | [t] <- patTypes pat = do tmp <- newVName "tmp" let rowt = rowType t- newbnd = Let pat aux $ Op $ Screma d [] $ mapSOAC lam- tmpbnd =+ newstm = Let pat aux $ Op $ Screma d [] $ mapSOAC lam+ tmpstm = Let (Pat [PatElem tmp rowt]) aux $ BasicOp $ Replicate (Shape ds) v lam = Lambda { lambdaReturnType = [rowt], lambdaParams = [],- lambdaBody = mkBody (oneStm tmpbnd) [varRes tmp]+ lambdaBody = mkBody (oneStm tmpstm) [varRes tmp] }- maybeDistributeStm newbnd acc+ maybeDistributeStm newstm acc maybeDistributeStm stm@(Let _ aux (BasicOp (Copy stm_arr))) acc = distributeSingleUnaryStm acc stm stm_arr $ \_ outerpat arr -> return $ oneStm $ Let outerpat aux $ BasicOp $ Copy arr@@ -635,8 +635,8 @@ \pat _ _ _ (x' : xs') -> let d' = d + length (snd nest) + 1 in addStm $ Let pat aux $ BasicOp $ Concat d' x' xs' w-maybeDistributeStm bnd acc =- addStmToAcc bnd acc+maybeDistributeStm stm acc =+ addStmToAcc stm acc distributeSingleUnaryStm :: (MonadFreshNames m, LocalScope rep m, DistRep rep) =>@@ -719,18 +719,18 @@ DistAcc rep ) )-distributeSingleStm acc bnd = do+distributeSingleStm acc stm = do nest <- asks distNest mk_lvl <- mkSegLevel tryDistribute mk_lvl nest (distTargets acc) (distStms acc) >>= \case Nothing -> return Nothing- Just (targets, distributed_bnds) ->- tryDistributeStm nest targets bnd >>= \case+ Just (targets, distributed_stms) ->+ tryDistributeStm nest targets stm >>= \case Nothing -> return Nothing Just (res, targets', new_kernel_nest) -> return $ Just- ( PostStms distributed_bnds,+ ( PostStms distributed_stms, res, new_kernel_nest, DistAcc@@ -793,10 +793,10 @@ kernel_inps' = filter ((`nameIn` freeIn k_body) . kernelInputName) kernel_inps - (k, k_bnds) <- mapKernel mk_lvl ispace kernel_inps' rts k_body+ (k, k_stms) <- mapKernel mk_lvl ispace kernel_inps' rts k_body traverse renameStm <=< runBuilder_ $ do- addStms k_bnds+ addStms k_stms let pat = Pat . rearrangeShape perm $@@ -1173,11 +1173,11 @@ DistAcc rep -> Maybe (Stms rep) -> DistNestT rep m (DistAcc rep)-kernelOrNot cs bnd acc _ _ Nothing =- addStmToAcc (certify cs bnd) acc-kernelOrNot cs _ _ kernels acc' (Just bnds) = do+kernelOrNot cs stm acc _ _ Nothing =+ addStmToAcc (certify cs stm) acc+kernelOrNot cs _ _ kernels acc' (Just stms) = do addPostStms kernels- postStm $ fmap (certify cs) bnds+ postStm $ fmap (certify cs) stms return acc' distributeMap ::@@ -1193,7 +1193,7 @@ w lam arrs- (distribute =<< distributeMapBodyStms acc' lam_bnds)+ (distribute =<< distributeMapBodyStms acc' lam_stms) where acc' = DistAcc@@ -1204,4 +1204,4 @@ distStms = mempty } - lam_bnds = bodyStms $ lambdaBody lam+ lam_stms = bodyStms $ lambdaBody lam
src/Futhark/Pass/ExtractKernels/Distribution.hs view
@@ -355,8 +355,8 @@ Targets -> Stm rep -> (DistributionBody, Result)-distributionBodyFromStm targets bnd =- distributionBodyFromStms targets $ oneStm bnd+distributionBodyFromStm targets stm =+ distributionBodyFromStms targets $ oneStm stm createKernelNest :: forall rep m.@@ -567,10 +567,10 @@ createKernelNest nest dist_body >>= \case Just (targets', distributed) -> do- (kernel_bnd, w_bnds) <-+ (kernel_stm, w_stms) <- localScope (targetsScope targets') $ constructKernel mk_lvl distributed $ mkBody stms inner_body_res- distributed' <- renameStm kernel_bnd+ distributed' <- renameStm kernel_stm logMsg $ "distributing\n" ++ unlines (map pretty $ stmsToList stms)@@ -581,7 +581,7 @@ ++ ppTargets targets ++ "\nand with new targets\n" ++ ppTargets targets'- return $ Just (targets', w_bnds <> oneStm distributed')+ return $ Just (targets', w_stms <> oneStm distributed') Nothing -> return Nothing where@@ -593,8 +593,8 @@ Targets -> Stm rep -> m (Maybe (Result, Targets, KernelNest))-tryDistributeStm nest targets bnd =+tryDistributeStm nest targets stm = fmap addRes <$> createKernelNest nest dist_body where- (dist_body, res) = distributionBodyFromStm targets bnd+ (dist_body, res) = distributionBodyFromStm targets stm addRes (targets', kernel_nest) = (res, targets', kernel_nest)
src/Futhark/Pass/ExtractKernels/ISRWIM.hs view
@@ -123,8 +123,8 @@ ) $ varsRes $ patNames map_pat Just m -> localScope (scopeOfLParams map_params) $ do- map_body_bnds <- collectStms_ m- return $ mkBody map_body_bnds $ varsRes $ patNames map_pat+ map_body_stms <- collectStms_ m+ return $ mkBody map_body_stms $ varsRes $ patNames map_pat let map_fun' = Lambda map_params map_body map_rettype @@ -140,13 +140,13 @@ Maybe (Pat, Certs, SubExp, Lambda) rwimPossible fun | Body _ stms res <- lambdaBody fun,- [bnd] <- stmsToList stms, -- Body has a single binding- map_pat <- stmPat bnd,+ [stm] <- stmsToList stms, -- Body has a single binding+ map_pat <- stmPat stm, map Var (patNames map_pat) == map resSubExp res, -- Returned verbatim- Op (Screma map_w map_arrs form) <- stmExp bnd,+ Op (Screma map_w map_arrs form) <- stmExp stm, Just map_fun <- isMapSOAC form, map paramName (lambdaParams fun) == map_arrs =- Just (map_pat, stmCerts bnd, map_w, map_fun)+ Just (map_pat, stmCerts stm, map_w, map_fun) | otherwise = Nothing
src/Futhark/Pass/ExtractKernels/Interchange.hs view
@@ -65,13 +65,13 @@ -- small simplification, we just remove the parameter outright if -- it is not used anymore. This might happen if the parameter was -- used just as the inital value of a merge parameter.- ((params', arrs'), pre_copy_bnds) <-+ ((params', arrs'), pre_copy_stms) <- runBuilder $ localScope (scopeOfLParams new_params) $ unzip . catMaybes <$> mapM copyOrRemoveParam params_and_arrs let lam = Lambda (params' <> new_params) body rettype- map_bnd =+ map_stm = Let loop_pat_expanded aux $ Op $ Screma w (arrs' <> new_arrs) (mapSOAC lam) res = varsRes $ patNames loop_pat_expanded@@ -79,7 +79,7 @@ return $ SeqLoop perm pat' merge_expanded form $- mkBody (pre_copy_bnds <> oneStm map_bnd) res+ mkBody (pre_copy_stms <> oneStm map_stm) res where free_in_body = freeIn body @@ -119,11 +119,11 @@ SeqLoop -> m (Stms SOACS) interchangeLoops nest loop = do- (loop', bnds) <-+ (loop', stms) <- runBuilder $ foldM (interchangeLoop isMapParameter) loop $ reverse $ kernelNestLoops nest- return $ bnds <> oneStm (seqLoopStm loop')+ return $ stms <> oneStm (seqLoopStm loop') where isMapParameter v = fmap snd $@@ -156,8 +156,8 @@ mkBranch branch = (renameBody =<<) $ do let lam = Lambda params branch lam_ret res = varsRes $ patNames branch_pat'- map_bnd = Let branch_pat' aux $ Op $ Screma w arrs $ mapSOAC lam- return $ mkBody (oneStm map_bnd) res+ map_stm = Let branch_pat' aux $ Op $ Screma w arrs $ mapSOAC lam+ return $ mkBody (oneStm map_stm) res tbranch' <- mkBranch tbranch fbranch' <- mkBranch fbranch@@ -171,9 +171,9 @@ Branch -> m (Stms SOACS) interchangeBranch nest loop = do- (loop', bnds) <-+ (loop', stms) <- runBuilder $ foldM interchangeBranch1 loop $ reverse $ kernelNestLoops nest- return $ bnds <> oneStm (branchStm loop')+ return $ stms <> oneStm (branchStm loop') data WithAccStm = WithAccStm [Int] Pat [(Shape, [VName], Maybe (Lambda, [SubExp]))] Lambda
src/Futhark/Pass/ExtractKernels/Intragroup.hs view
@@ -274,13 +274,13 @@ Op (Stream w arrs Sequential accs lam) | chunk_size_param : _ <- lambdaParams lam -> do types <- asksScope castScope- ((), stream_bnds) <-+ ((), stream_stms) <- runBuilderT (sequentialStreamWholeArray pat w accs lam arrs) types let replace (Var v) | v == paramName chunk_size_param = w replace se = se replaceSets (IntraAcc x y log) = IntraAcc (S.map (map replace) x) (S.map (map replace) y) log- censor replaceSets $ intraGroupStms lvl stream_bnds+ censor replaceSets $ intraGroupStms lvl stream_stms Op (Scatter w lam ivs dests) -> do write_i <- newVName "write_i" space <- mkSegSpace [(write_i, w)]
src/Futhark/Pass/ExtractKernels/StreamKernel.hs view
@@ -184,10 +184,10 @@ | not $ primType $ paramType p = mkLet [paramIdent p] $ BasicOp $ Copy v mkAccInit p x = mkLet [paramIdent p] $ BasicOp $ SubExp x- acc_init_bnds = stmsFromList $ zipWith mkAccInit fold_acc_params nes+ acc_init_stms = stmsFromList $ zipWith mkAccInit fold_acc_params nes return lam- { lambdaBody = insertStms acc_init_bnds $ lambdaBody lam,+ { lambdaBody = insertStms acc_init_stms $ lambdaBody lam, lambdaParams = thread_index_param : fold_chunk_param : fold_inp_params }
src/Futhark/Pass/KernelBabysitting.hs view
@@ -98,9 +98,9 @@ return $ M.fromList [(name, stm') | name <- patNames pat] <> expmap transformStm expmap (Let pat aux e) = do e' <- mapExpM (transform expmap) e- let bnd' = Let pat aux e'- addStm bnd'- return $ M.fromList [(name, bnd') | name <- patNames pat] <> expmap+ let stm' = Let pat aux e'+ addStm stm'+ return $ M.fromList [(name, stm') | name <- patNames pat] <> expmap transform :: ExpMap -> Mapper GPU GPU BabysitM transform expmap =@@ -517,9 +517,9 @@ varianceInStms t = foldl varianceInStm t . stmsToList varianceInStm :: VarianceTable -> Stm GPU -> VarianceTable-varianceInStm variance bnd =- foldl' add variance $ patNames $ stmPat bnd+varianceInStm variance stm =+ foldl' add variance $ patNames $ stmPat stm where add variance' v = M.insert v binding_variance variance' look variance' v = oneName v <> M.findWithDefault mempty v variance'- binding_variance = mconcat $ map (look variance) $ namesToList (freeIn bnd)+ binding_variance = mconcat $ map (look variance) $ namesToList (freeIn stm)
src/Futhark/TypeCheck.hs view
@@ -441,10 +441,10 @@ Scope (Aliases rep) -> TypeM rep a -> TypeM rep a-binding bnds = check . local (`bindVars` bnds)+binding stms = check . local (`bindVars` stms) where bindVars = M.foldlWithKey' bindVar- boundnames = M.keys bnds+ boundnames = M.keys stms bindVar env name (LetName (AliasDec als, dec)) = let als'@@ -460,15 +460,15 @@ -- Check whether the bound variables have been used correctly -- within their scope. check m = do- mapM_ bound $ M.keys bnds+ mapM_ bound $ M.keys stms (a, os) <- collectOccurences m tell $ Consumption $ unOccur (namesFromList boundnames) os return a lookupVar :: VName -> TypeM rep (NameInfo (Aliases rep)) lookupVar name = do- bnd <- asks $ M.lookup name . envVtable- case bnd of+ stm <- asks $ M.lookup name . envVtable+ case stm of Nothing -> bad $ UnknownVariableError name Just dec -> return dec @@ -494,8 +494,8 @@ [SubExp] -> TypeM rep ([RetType rep], [DeclType]) lookupFun fname args = do- bnd <- asks $ M.lookup fname . envFtable- case bnd of+ stm <- asks $ M.lookup fname . envFtable+ case stm of Nothing -> bad $ UnknownFunctionError fname Just (ftype, params) -> do argts <- mapM subExpType args@@ -719,13 +719,13 @@ Stms (Aliases rep) -> TypeM rep a -> TypeM rep a-checkStms origbnds m = delve $ stmsToList origbnds+checkStms origstms m = delve $ stmsToList origstms where- delve (stm@(Let pat _ e) : bnds) = do+ delve (stm@(Let pat _ e) : stms) = do context (pretty $ "In expression of statement" </> indent 2 (ppr pat)) $ checkExp e checkStm stm $- delve bnds+ delve stms delve [] = m @@ -740,28 +740,28 @@ [RetType rep] -> Body (Aliases rep) -> TypeM rep [Names]-checkFunBody rt (Body (_, rep) bnds res) = do+checkFunBody rt (Body (_, rep) stms res) = do checkBodyDec rep- checkStms bnds $ do+ checkStms stms $ do context "When checking body result" $ checkResult res context "When matching declared return type to result of body" $ matchReturnType rt res map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res where- bound_here = namesFromList $ M.keys $ scopeOf bnds+ bound_here = namesFromList $ M.keys $ scopeOf stms checkLambdaBody :: Checkable rep => [Type] -> Body (Aliases rep) -> TypeM rep [Names]-checkLambdaBody ret (Body (_, rep) bnds res) = do+checkLambdaBody ret (Body (_, rep) stms res) = do checkBodyDec rep- checkStms bnds $ do+ checkStms stms $ do checkLambdaResult ret res map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res where- bound_here = namesFromList $ M.keys $ scopeOf bnds+ bound_here = namesFromList $ M.keys $ scopeOf stms checkLambdaResult :: Checkable rep =>@@ -792,13 +792,13 @@ Checkable rep => Body (Aliases rep) -> TypeM rep [Names]-checkBody (Body (_, rep) bnds res) = do+checkBody (Body (_, rep) stms res) = do checkBodyDec rep- checkStms bnds $ do+ checkStms stms $ do checkResult res map (`namesSubtract` bound_here) <$> mapM (subExpAliasesM . resSubExp) res where- bound_here = namesFromList $ M.keys $ scopeOf bnds+ bound_here = namesFromList $ M.keys $ scopeOf stms checkBasicOp :: Checkable rep => BasicOp -> TypeM rep () checkBasicOp (SubExp es) =
src/Futhark/Util/Options.hs view
@@ -3,6 +3,7 @@ ( FunOptDescr, mainWithOptions, commonOptions,+ optionsError, module System.Console.GetOpt, ) where@@ -11,6 +12,7 @@ import Data.List (sortBy) import Futhark.Version import System.Console.GetOpt+import System.Environment (getProgName) import System.Exit import System.IO @@ -102,3 +104,11 @@ putStrLn "Copyright (C) DIKU, University of Copenhagen, released under the ISC license." putStrLn "This is free software: you are free to change and redistribute it." putStrLn "There is NO WARRANTY, to the extent permitted by law."++-- | Terminate the program with this error message (but don't report+-- it as an ICE, as happens with 'error').+optionsError :: String -> IO ()+optionsError s = do+ prog <- getProgName+ hPutStrLn stderr $ prog <> ": " <> s+ exitWith $ ExitFailure 2
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -942,17 +942,17 @@ bindNameMap (patternNameMap p') $ m p' binding :: [Ident] -> TermTypeM a -> TermTypeM a-binding bnds = check . handleVars+binding stms = check . handleVars where handleVars m =- localScope (`bindVars` bnds) $ do+ localScope (`bindVars` stms) $ do -- Those identifiers that can potentially also be sizes are -- added as type constraints. This is necessary so that we -- can properly detect scope violations during unification. -- We do this for *all* identifiers, not just those that are -- integers, because they may become integers later due to -- inference...- forM_ bnds $ \ident ->+ forM_ stms $ \ident -> constrain (identName ident) $ ParamSize $ srclocOf ident m @@ -986,11 +986,11 @@ (a, usages) <- collectBindingsOccurences m checkOccurences usages - mapM_ (checkIfUsed usages) bnds+ mapM_ (checkIfUsed usages) stms return a - -- Collect and remove all occurences in @bnds@. This relies+ -- Collect and remove all occurences in @stms@. This relies -- on the fact that no variables shadow any other. collectBindingsOccurences m = do (x, usage) <- collectOccurences m@@ -1010,7 +1010,7 @@ occ {observed = obs2, consumed = con2} ) )- names = S.fromList $ map identName bnds+ names = S.fromList $ map identName stms divide s = (s `S.intersection` names, s `S.difference` names) bindingTypes ::