futhark 0.21.3 → 0.21.4
raw patch · 9 files changed
+193/−166 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- futhark.cabal +1/−1
- rts/c/opencl.h +4/−1
- src/Futhark/CodeGen/Backends/GenericC/CLI.hs +1/−2
- src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs +9/−16
- src/Futhark/Pass/ExtractKernels.hs +27/−16
- src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +3/−3
- src/Futhark/Pass/ExtractKernels/DistributeNests.hs +1/−4
- src/Futhark/Pass/ExtractKernels/Distribution.hs +4/−5
- src/Language/Futhark/TypeChecker/Terms/DoLoop.hs +143/−118
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark-version: 0.21.3+version: 0.21.4 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to
rts/c/opencl.h view
@@ -878,7 +878,10 @@ } int x = 2;- error = clEnqueueWriteBuffer(ctx->queue, *mem_out, 1, 0, sizeof(x), &x, 0, NULL, NULL);+ error = clEnqueueWriteBuffer(ctx->queue, *mem_out,+ CL_TRUE,+ 0, sizeof(x), &x,+ 0, NULL, NULL); // No need to wait for completion here. clWaitForEvents() cannot // return mem object allocation failures. This implies that the
src/Futhark/CodeGen/Backends/GenericC/CLI.hs view
@@ -209,10 +209,9 @@ $id:shape, $int:rank) != 0) {- futhark_panic(1, "Cannot read input #%d of type %s%s (errno: %s).\n",+ futhark_panic(1, "Cannot read input #%d of type %s (errno: %s).\n", $int:i, $string:(T.unpack tname),- $id:info.type_name, strerror(errno)); }|] in ( items,
src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs view
@@ -124,11 +124,8 @@ Space "device" multiHistoCase = do- let num_elems =- foldl' (*) (sExt64 $ tvExp num_subhistos) $- map toInt64Exp $ arrayDims dest_t-- let subhistos_mem_size =+ let num_elems = product $ map toInt64Exp $ shapeDims subhistos_shape+ subhistos_mem_size = Imp.bytes $ Imp.unCount (Imp.elements num_elems `Imp.withElemType` elemType dest_t) @@ -464,7 +461,7 @@ let bucket_is = map Imp.le64 (init space_is) ++ [sExt64 subhisto_ind]- ++ unflattenIndex dest_shape' (flat_bucket - chk_beg)+ ++ unflattenIndex dest_shape' flat_bucket dLParams $ lambdaParams lam sLoopNest shape $ \is -> do forM_ (zip vs_params vs') $ \(p, res) ->@@ -519,20 +516,16 @@ prepareIntermediateArraysLocal :: TV Int32 -> Count NumGroups (Imp.TExp Int64) ->- SegSpace -> [SegHistSlug] -> CallKernelGen InitLocalHistograms-prepareIntermediateArraysLocal num_subhistos_per_group groups_per_segment space slugs = do- num_segments <-- dPrimVE "num_segments" $- product $ map (toInt64Exp . snd) $ init $ unSegSpace space- mapM (onOp num_segments) slugs+prepareIntermediateArraysLocal num_subhistos_per_group groups_per_segment =+ mapM onOp where- onOp num_segments (SegHistSlug op num_subhistos subhisto_info do_op) = do- num_subhistos <-- sExt64 (unCount groups_per_segment) * num_segments+ onOp (SegHistSlug op num_subhistos subhisto_info do_op) = do+ num_subhistos <-- sExt64 (unCount groups_per_segment) emit $- Imp.DebugPrint "Number of subhistograms in global memory" $+ Imp.DebugPrint "Number of subhistograms in global memory per segment" $ Just $ untyped $ tvExp num_subhistos mk_op <-@@ -849,7 +842,7 @@ Just $ untyped num_subhistos_per_group init_histograms <-- prepareIntermediateArraysLocal num_subhistos_per_group_var groups_per_segment space slugs+ prepareIntermediateArraysLocal num_subhistos_per_group_var groups_per_segment slugs sFor "chk_i" hist_S $ \chk_i -> histKernelLocalPass
src/Futhark/Pass/ExtractKernels.hs view
@@ -339,8 +339,7 @@ let alt_body = mkBody alt_stms $ varsRes $ patNames alts_pat letBind pat $- If cond alt alt_body $- IfDec (staticShapes (patTypes pat)) IfEquiv+ If cond alt alt_body $ IfDec (staticShapes (patTypes pat)) IfEquiv transformLambda :: KernelPath -> Lambda -> DistribM (Out.Lambda Out.GPU) transformLambda path (Lambda params body ret) =@@ -856,6 +855,19 @@ group_par_body <- renameBody $ mkBody intra_stms res pure (group_par_body, intra_ok, intra_suff_key, intra_suff_stms) +removeUnusedMapResults ::+ PatT Type ->+ [SubExpRes] ->+ LambdaT rep ->+ Maybe ([Int], PatT Type, LambdaT rep)+removeUnusedMapResults (Pat pes) res lam = do+ let (pes', body_res) =+ unzip $ filter (used . fst) $ zip pes $ bodyResult (lambdaBody lam)+ perm <- map (Var . patElemName) pes' `isPermutationOf` map resSubExp res+ pure (perm, Pat pes', lam {lambdaBody = (lambdaBody lam) {bodyResult = body_res}})+ where+ used pe = patElemName pe `nameIn` freeIn res+ onInnerMap :: KernelPath -> MapLoop ->@@ -868,16 +880,16 @@ | otherwise = distributeSingleStm acc (mapLoopStm maploop) >>= \case Just (post_kernels, res, nest, acc')- | Just (perm, _pat_unused) <- permutationAndMissing pat res -> do+ | Just (perm, pat', lam') <- removeUnusedMapResults pat res lam -> do addPostStms post_kernels- multiVersion perm nest acc'+ multiVersion perm nest acc' pat' lam' _ -> distributeMap maploop acc where discardTargets acc' = -- FIXME: work around bogus targets. acc' {distTargets = singleTarget (mempty, mempty)} - multiVersion perm nest acc' = do+ multiVersion perm nest acc' pat' lam' = do -- The kernel can be distributed by itself, so now we can -- decide whether to just sequentialise, or exploit inner -- parallelism.@@ -886,7 +898,7 @@ stms <- liftInner $ localScope extra_scope $ do- let maploop' = MapLoop pat aux w lam arrs+ let maploop' = MapLoop pat' aux w lam' arrs exploitInnerParallelism path' = do let dist_env' =@@ -894,27 +906,26 @@ { distOnTopLevelStms = onTopLevelStms path', distOnInnerMap = onInnerMap path' }- runDistNestT dist_env' $- inNesting nest $- localScope extra_scope $- discardTargets <$> distributeMap maploop' acc {distStms = mempty}+ runDistNestT dist_env' . inNesting nest . localScope extra_scope $+ discardTargets+ <$> distributeMap maploop' acc {distStms = mempty} -- Normally the permutation is for the output pattern, but -- we can't really change that, so we change the result -- order instead. let lam_res' = rearrangeShape (rearrangeInverse perm) $- bodyResult $ lambdaBody lam- lam' = lam {lambdaBody = (lambdaBody lam) {bodyResult = lam_res'}}- map_nesting = MapNesting pat aux w $ zip (lambdaParams lam) arrs- nest' = pushInnerKernelNesting (pat, lam_res') map_nesting nest+ bodyResult $ lambdaBody lam'+ lam'' = lam' {lambdaBody = (lambdaBody lam') {bodyResult = lam_res'}}+ map_nesting = MapNesting pat' aux w $ zip (lambdaParams lam') arrs+ nest' = pushInnerKernelNesting (pat', lam_res') map_nesting nest -- XXX: we do not construct a new KernelPath when -- sequentialising. This is only OK as long as further -- versioning does not take place down that branch (it currently -- does not). (sequentialised_kernel, nestw_stms) <- localScope extra_scope $ do- let sequentialised_lam = soacsLambdaToGPU lam'+ let sequentialised_lam = soacsLambdaToGPU lam'' constructKernel segThreadCapped nest' $ lambdaBody sequentialised_lam let outer_pat = loopNestingPat $ fst nest@@ -925,7 +936,7 @@ (const $ return $ oneStm sequentialised_kernel) exploitInnerParallelism outer_pat- lam'+ lam'' postStm stms return acc'
src/Futhark/Pass/ExtractKernels/BlockedKernel.hs view
@@ -71,7 +71,7 @@ res <- bodyBind (lambdaBody map_lam) forM res $ \(SubExpRes res_cs se) -> pure $ Returns ResultMaySimplify res_cs se - return (space, kbody)+ pure (space, kbody) segRed :: (MonadFreshNames m, DistRep rep, HasScope rep m) =>@@ -208,7 +208,7 @@ read_input_stms <- runBuilder_ $ mapM readKernelInput inputs space <- mkSegSpace ispace- return (space, read_input_stms)+ pure (space, read_input_stms) mapKernel :: (DistRep rep, HasScope rep m, MonadFreshNames m) =>@@ -232,7 +232,7 @@ lvl <- mk_lvl (map snd ispace) "segmap" r - return $ SegMap lvl space rts kbody'+ pure $ SegMap lvl space rts kbody' data KernelInput = KernelInput { kernelInputName :: VName,
src/Futhark/Pass/ExtractKernels/DistributeNests.hs view
@@ -1146,10 +1146,7 @@ -- Add extra pattern elements to every kernel nesting level. expandKernelNest ::- MonadFreshNames m =>- [PatElemT Type] ->- KernelNest ->- m KernelNest+ MonadFreshNames m => [PatElemT Type] -> KernelNest -> m KernelNest expandKernelNest pes (outer_nest, inner_nests) = do let outer_size = loopNestingWidth outer_nest :
src/Futhark/Pass/ExtractKernels/Distribution.hs view
@@ -258,11 +258,10 @@ rts = map (stripArray (length ispace)) $ patTypes pat inner_body' <- fmap (uncurry (flip (KernelBody ()))) $- runBuilder $- localScope ispace_scope $ do- mapM_ readKernelInput $ filter inputIsUsed inps- res <- bodyBind inner_body- forM res $ \(SubExpRes cs se) -> pure $ Returns ResultMaySimplify cs se+ runBuilder . localScope ispace_scope $ do+ mapM_ readKernelInput $ filter inputIsUsed inps+ res <- bodyBind inner_body+ forM res $ \(SubExpRes cs se) -> pure $ Returns ResultMaySimplify cs se (segop, aux_stms) <- lift $ mapKernel mk_lvl ispace [] rts inner_body'
src/Language/Futhark/TypeChecker/Terms/DoLoop.hs view
@@ -24,10 +24,10 @@ import Futhark.Util.Pretty hiding (bool, group, space) import Language.Futhark import Language.Futhark.TypeChecker.Monad hiding (BoundV)-import Language.Futhark.TypeChecker.Terms.Monad+import Language.Futhark.TypeChecker.Terms.Monad hiding (consumed) import Language.Futhark.TypeChecker.Terms.Pat import Language.Futhark.TypeChecker.Types-import Language.Futhark.TypeChecker.Unify hiding (Usage)+import Language.Futhark.TypeChecker.Unify import Prelude hiding (mod) -- | Replace specified sizes with distinct fresh size variables.@@ -69,6 +69,125 @@ pure $ NamedDim $ qualName v onDim d = pure d +-- | Mark bindings of names in "consumed" as Unique.+uniquePat :: Names -> Pat -> Pat+uniquePat consumed = recurse+ where+ recurse (Wildcard (Info t) wloc) =+ Wildcard (Info $ t `setUniqueness` Nonunique) wloc+ recurse (PatParens p ploc) =+ PatParens (recurse p) ploc+ recurse (PatAttr attr p ploc) =+ PatAttr attr (recurse p) ploc+ recurse (Id name (Info t) iloc)+ | name `S.member` consumed =+ let t' = t `setUniqueness` Unique `setAliases` mempty+ in Id name (Info t') iloc+ | otherwise =+ let t' = t `setUniqueness` Nonunique+ in Id name (Info t') iloc+ recurse (TuplePat pats ploc) =+ TuplePat (map recurse pats) ploc+ recurse (RecordPat fs ploc) =+ RecordPat (map (fmap recurse) fs) ploc+ recurse (PatAscription p t ploc) =+ PatAscription p t ploc+ recurse p@PatLit {} = p+ recurse (PatConstr n t ps ploc) =+ PatConstr n t (map recurse ps) ploc++convergePat :: SrcLoc -> Pat -> Names -> PatType -> Usage -> TermTypeM Pat+convergePat loop_loc pat body_cons body_t body_loc = do+ let -- Make the pattern unique where needed.+ pat' = uniquePat (patNames pat `S.intersection` body_cons) pat++ pat_t <- normTypeFully $ patternType pat'+ unless (toStructural body_t `subtypeOf` toStructural pat_t) $+ unexpectedType (srclocOf body_loc) (toStruct body_t) [toStruct pat_t]++ -- Check that the new values of consumed merge parameters do not+ -- alias something bound outside the loop, AND that anything+ -- returned for a unique merge parameter does not alias anything+ -- else returned. We also update the aliases for the pattern.+ bound_outside <- asks $ S.fromList . M.keys . scopeVtable . termScope+ let combAliases t1 t2 =+ case t1 of+ Scalar Record {} -> t1+ _ -> t1 `addAliases` (<> aliases t2)++ checkMergeReturn (Id pat_v (Info pat_v_t) patloc) t+ | unique pat_v_t,+ v : _ <-+ S.toList $+ S.map aliasVar (aliases t) `S.intersection` bound_outside =+ lift . typeError loop_loc mempty $+ "Return value for loop parameter"+ <+> pquote (pprName pat_v)+ <+> "aliases"+ <+> pprName v <> "."+ | otherwise = do+ (cons, obs) <- get+ unless (S.null $ aliases t `S.intersection` cons) $+ lift . typeError loop_loc mempty $+ "Return value for loop parameter"+ <+> pquote (pprName pat_v)+ <+> "aliases other consumed loop parameter."+ when+ ( unique pat_v_t+ && not (S.null (aliases t `S.intersection` (cons <> obs)))+ )+ $ lift . typeError loop_loc mempty $+ "Return value for consuming loop parameter"+ <+> pquote (pprName pat_v)+ <+> "aliases previously returned value."+ if unique pat_v_t+ then put (cons <> aliases t, obs)+ else put (cons, obs <> aliases t)++ pure $ Id pat_v (Info (combAliases pat_v_t t)) patloc+ checkMergeReturn (Wildcard (Info pat_v_t) patloc) t =+ pure $ Wildcard (Info (combAliases pat_v_t t)) patloc+ checkMergeReturn (PatParens p _) t =+ checkMergeReturn p t+ checkMergeReturn (PatAscription p _ _) t =+ checkMergeReturn p t+ checkMergeReturn (RecordPat pfs patloc) (Scalar (Record tfs)) =+ RecordPat . M.toList <$> sequence pfs' <*> pure patloc+ where+ pfs' = M.intersectionWith checkMergeReturn (M.fromList pfs) tfs+ checkMergeReturn (TuplePat pats patloc) t+ | Just ts <- isTupleRecord t =+ TuplePat <$> zipWithM checkMergeReturn pats ts <*> pure patloc+ checkMergeReturn p _ =+ pure p++ (pat'', (pat_cons, _)) <-+ runStateT (checkMergeReturn pat' body_t) (mempty, mempty)++ let body_cons' = body_cons <> S.map aliasVar pat_cons+ if body_cons' == body_cons && patternType pat'' == patternType pat+ then pure pat'+ else convergePat loop_loc pat'' body_cons' body_t body_loc++data ArgSource = Initial | BodyResult++wellTypedLoopArg :: ArgSource -> [VName] -> Pat -> Exp -> TermTypeM ()+wellTypedLoopArg src sparams pat arg = do+ (merge_t, _) <-+ freshDimsInType (srclocOf arg) Nonrigid "loop" (S.fromList sparams) $+ toStruct $ patternType pat+ arg_t <- toStruct <$> expTypeFully arg+ onFailure (checking merge_t arg_t) $+ unify+ (mkUsage (srclocOf arg) desc)+ merge_t+ arg_t+ where+ (checking, desc) =+ case src of+ Initial -> (CheckingLoopInitial, "matching initial loop values to pattern")+ BodyResult -> (CheckingLoopBody, "matching loop body to pattern")+ -- | An un-checked loop. type UncheckedLoop = (UncheckedPat, UncheckedExp, LoopFormBase NoInfo Name, UncheckedExp)@@ -104,11 +223,14 @@ -- variant, and these are turned into size parameters for the merge -- pattern. --- -- (3) We now conceptually have a function parameter type and return- -- type. We check that it can be called with the initial merge- -- values as argument. The result of this is the type of the loop- -- as a whole.+ -- (3) We now conceptually have a function parameter type and+ -- return type. We check that it can be called with the body type+ -- as argument. --+ -- (4) Similarly to (3), we check that the "function" can be+ -- called with the initial merge values as argument. The result+ -- of this is the type of the loop as a whole.+ -- -- (There is also a convergence loop for inferring uniqueness, but -- that's orthogonal to the size handling.) @@ -164,6 +286,18 @@ mergepat'' <- applySubst (`M.lookup` init_substs) <$> updateTypes mergepat' + -- Eliminate those new_dims that turned into sparams so it won't+ -- look like we have ambiguous sizes lying around.+ modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` sparams++ -- dim handling (3)+ --+ -- The only trick here is that we have to turn any instances+ -- of loop parameters in the type of loopbody' rigid,+ -- because we are no longer in a position to change them,+ -- really.+ wellTypedLoopArg BodyResult sparams mergepat'' loopbody'+ pure (nubOrd sparams, mergepat'') -- First we do a basic check of the loop body to figure out which of@@ -232,7 +366,7 @@ mergepat'' <- do loopbody_t <- expTypeFully loopbody'- convergePat mergepat' (allConsumed bodyflow) loopbody_t $+ convergePat loc mergepat' (allConsumed bodyflow) loopbody_t $ mkUsage (srclocOf loopbody') "being (part of) the result of the loop body" let consumeMerge (Id _ (Info pt) ploc) mt@@ -248,16 +382,8 @@ pure () consumeMerge mergepat'' =<< expTypeFully mergeexp' - -- dim handling (3)- merge_t' <-- someDimsFreshInType loc Nonrigid "loop" (S.fromList sparams) $- toStruct $ patternType mergepat''- mergeexp_t <- toStruct <$> expTypeFully mergeexp'- onFailure (CheckingLoopInitial merge_t' mergeexp_t) $- unify- (mkUsage (srclocOf mergeexp') "matching initial loop values to pattern")- merge_t'- mergeexp_t+ -- dim handling (4)+ wellTypedLoopArg Initial sparams mergepat'' mergeexp' (loopt, retext) <- freshDimsInType loc (Rigid RigidLoop) "loop" (S.fromList sparams) $@@ -276,105 +402,4 @@ second (`S.difference` S.map AliasBound bound_here) $ loopt `setUniqueness` Unique - -- Eliminate those new_dims that turned into sparams so it won't- -- look like we have ambiguous sizes lying around.- modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` sparams- pure ((sparams, mergepat'', mergeexp', form', loopbody'), AppRes loopt' retext)- where- convergePat pat body_cons body_t body_loc = do- let consumed_merge = patNames pat `S.intersection` body_cons-- uniquePat (Wildcard (Info t) wloc) =- Wildcard (Info $ t `setUniqueness` Nonunique) wloc- uniquePat (PatParens p ploc) =- PatParens (uniquePat p) ploc- uniquePat (PatAttr attr p ploc) =- PatAttr attr (uniquePat p) ploc- uniquePat (Id name (Info t) iloc)- | name `S.member` consumed_merge =- let t' = t `setUniqueness` Unique `setAliases` mempty- in Id name (Info t') iloc- | otherwise =- let t' = t `setUniqueness` Nonunique- in Id name (Info t') iloc- uniquePat (TuplePat pats ploc) =- TuplePat (map uniquePat pats) ploc- uniquePat (RecordPat fs ploc) =- RecordPat (map (fmap uniquePat) fs) ploc- uniquePat (PatAscription p t ploc) =- PatAscription p t ploc- uniquePat p@PatLit {} = p- uniquePat (PatConstr n t ps ploc) =- PatConstr n t (map uniquePat ps) ploc-- -- Make the pattern unique where needed.- pat' = uniquePat pat-- pat_t <- normTypeFully $ patternType pat'- unless (toStructural body_t `subtypeOf` toStructural pat_t) $- unexpectedType (srclocOf body_loc) (toStruct body_t) [toStruct pat_t]-- -- Check that the new values of consumed merge parameters do not- -- alias something bound outside the loop, AND that anything- -- returned for a unique merge parameter does not alias anything- -- else returned. We also update the aliases for the pattern.- bound_outside <- asks $ S.fromList . M.keys . scopeVtable . termScope- let combAliases t1 t2 =- case t1 of- Scalar Record {} -> t1- _ -> t1 `addAliases` (<> aliases t2)-- checkMergeReturn (Id pat_v (Info pat_v_t) patloc) t- | unique pat_v_t,- v : _ <-- S.toList $- S.map aliasVar (aliases t) `S.intersection` bound_outside =- lift . typeError loc mempty $- "Return value for loop parameter"- <+> pquote (pprName pat_v)- <+> "aliases"- <+> pprName v <> "."- | otherwise = do- (cons, obs) <- get- unless (S.null $ aliases t `S.intersection` cons) $- lift . typeError loc mempty $- "Return value for loop parameter"- <+> pquote (pprName pat_v)- <+> "aliases other consumed loop parameter."- when- ( unique pat_v_t- && not (S.null (aliases t `S.intersection` (cons <> obs)))- )- $ lift . typeError loc mempty $- "Return value for consuming loop parameter"- <+> pquote (pprName pat_v)- <+> "aliases previously returned value."- if unique pat_v_t- then put (cons <> aliases t, obs)- else put (cons, obs <> aliases t)-- pure $ Id pat_v (Info (combAliases pat_v_t t)) patloc- checkMergeReturn (Wildcard (Info pat_v_t) patloc) t =- pure $ Wildcard (Info (combAliases pat_v_t t)) patloc- checkMergeReturn (PatParens p _) t =- checkMergeReturn p t- checkMergeReturn (PatAscription p _ _) t =- checkMergeReturn p t- checkMergeReturn (RecordPat pfs patloc) (Scalar (Record tfs)) =- RecordPat . M.toList <$> sequence pfs' <*> pure patloc- where- pfs' = M.intersectionWith checkMergeReturn (M.fromList pfs) tfs- checkMergeReturn (TuplePat pats patloc) t- | Just ts <- isTupleRecord t =- TuplePat <$> zipWithM checkMergeReturn pats ts <*> pure patloc- checkMergeReturn p _ =- pure p-- (pat'', (pat_cons, _)) <-- runStateT (checkMergeReturn pat' body_t) (mempty, mempty)-- let body_cons' = body_cons <> S.map aliasVar pat_cons- if body_cons' == body_cons && patternType pat'' == patternType pat- then pure pat'- else convergePat pat'' body_cons' body_t body_loc