diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark -version: 0.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 diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.h @@ -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 diff --git a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs --- a/src/Futhark/CodeGen/Backends/GenericC/CLI.hs +++ b/src/Futhark/CodeGen/Backends/GenericC/CLI.hs @@ -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, diff --git a/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs b/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/GPU/SegHist.hs @@ -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 diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs --- a/src/Futhark/Pass/ExtractKernels.hs +++ b/src/Futhark/Pass/ExtractKernels.hs @@ -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' diff --git a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs --- a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs @@ -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, diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs --- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs +++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs @@ -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 : diff --git a/src/Futhark/Pass/ExtractKernels/Distribution.hs b/src/Futhark/Pass/ExtractKernels/Distribution.hs --- a/src/Futhark/Pass/ExtractKernels/Distribution.hs +++ b/src/Futhark/Pass/ExtractKernels/Distribution.hs @@ -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' diff --git a/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs b/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs --- a/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs +++ b/src/Language/Futhark/TypeChecker/Terms/DoLoop.hs @@ -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