futhark 0.20.7 → 0.20.8
raw patch · 19 files changed
+189/−77 lines, 19 filesdep ~futhark-dataPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: futhark-data
API changes (from Hackage documentation)
+ Language.Futhark.Syntax: SumDiet :: Map Name [Diet] -> Diet
- Language.Futhark.TypeChecker.Terms.Monad: returnAliased :: Name -> Name -> SrcLoc -> TermTypeM ()
+ Language.Futhark.TypeChecker.Terms.Monad: returnAliased :: Name -> SrcLoc -> TermTypeM ()
- Language.Futhark.TypeChecker.Terms.Monad: uniqueReturnAliased :: Name -> SrcLoc -> TermTypeM a
+ Language.Futhark.TypeChecker.Terms.Monad: uniqueReturnAliased :: SrcLoc -> TermTypeM a
Files
- docs/language-reference.rst +7/−1
- docs/man/futhark-literate.rst +5/−0
- futhark.cabal +2/−2
- prelude/array.fut +3/−3
- prelude/soacs.fut +12/−9
- prelude/zip.fut +1/−1
- src/Futhark/CLI/Literate.hs +26/−3
- src/Futhark/CLI/REPL.hs +9/−2
- src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +9/−1
- src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +15/−4
- src/Futhark/CodeGen/Backends/MulticoreC.hs +9/−1
- src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs +9/−1
- src/Futhark/Internalise/Exps.hs +10/−1
- src/Futhark/Internalise/Monomorphise.hs +5/−1
- src/Language/Futhark/Interpreter.hs +11/−2
- src/Language/Futhark/Prop.hs +1/−1
- src/Language/Futhark/Syntax.hs +2/−0
- src/Language/Futhark/TypeChecker/Terms.hs +47/−35
- src/Language/Futhark/TypeChecker/Terms/Monad.hs +6/−9
docs/language-reference.rst view
@@ -507,7 +507,7 @@ * An expression ``x.y`` may either be a reference to the name ``y`` in the module ``x``, or the field ``y`` in the record ``x``. Modules and values occupy the same name space, so this is disambiguated by- the type of ``x``.+ whether ``x`` is a value or module. * A type ascription (``exp : type``) cannot appear as an array index, as it conflicts with the syntax for slicing.@@ -540,6 +540,7 @@ ================= ============= left ``,`` left ``:``, ``:>``+ left ```op``` left ``||`` left ``&&`` left ``<=`` ``>=`` ``>`` ``<`` ``==`` ``!=``@@ -777,6 +778,11 @@ ``<``, ``<=``. ``>``, ``>=`` Company any two values of numeric type for equality.++ ```op```++ Use ``op``, which may be any non-operator function name, as an+ infix operator. ``x && y`` ..........
docs/man/futhark-literate.rst view
@@ -213,6 +213,11 @@ * ``$loadimg "file"`` reads an image from the given file and returns it as a row-major ``[][]u32`` array with each pixel encoded as ARGB. +* ``$loaddata "file"`` reads a dataset from the given file. When the file+ contains a singular value, it is returned as value. Otherwise, a tuple+ of values is returned, which should be destructured before use. For example:+ ``let (a, b) = $loaddata "foo.in" in bar a b``.+ SAFETY ======
futhark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark-version: 0.20.7+version: 0.20.8 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to@@ -330,7 +330,7 @@ , file-embed >=0.0.14.0 , filepath >=1.4.1.1 , free >=4.12.4- , futhark-data >= 1.0.2.0+ , futhark-data >= 1.0.3.0 , futhark-server >= 1.1.2.0 , githash >=0.1.6.1 , half >= 0.3
prelude/array.fut view
@@ -70,15 +70,15 @@ -- | Concatenation where the result has a predetermined size. If the -- provided size is wrong, the function will fail with a run-time -- error.-let concat_to [n] [m] 't (k: i64) (xs: [n]t) (ys: [m]t): *[k]t = xs ++ ys :> [k]t+let concat_to [n] [m] 't (k: i64) (xs: [n]t) (ys: [m]t): *[k]t = xs ++ ys :> *[k]t -- | Rotate an array some number of elements to the left. A negative -- rotation amount is also supported. ----- For example, if `b==rotate r a`, then `b[x+r] = a[x]`.+-- For example, if `b==rotate r a`, then `b[x] = a[x+r]`. -- -- **Complexity:** O(1).-let rotate [n] 't (r: i64) (xs: [n]t): [n]t = intrinsics.rotate (r, xs) :> [n]t+let rotate [n] 't (r: i64) (xs: [n]t): [n]t = intrinsics.rotate (r, xs) :> *[n]t -- | Construct an array of consecutive integers of the given length, -- starting at 0.
prelude/soacs.fut view
@@ -245,20 +245,23 @@ -- code: -- -- ```--- for index in 0..length is-1:--- i = is[index]--- v = vs[index]--- as[i] = v+-- for j in 0...length is-1:+-- i = is[j]+-- v = vs[j]+-- if i >= 0 && i < length as:+-- as[i] = v -- ``` -- -- The `is` and `vs` arrays must have the same outer size. `scatter` -- acts in-place and consumes the `as` array, returning a new array -- that has the same type and elements as `as`, except for the indices--- in `is`. If `is` contains duplicates (i.e. several writes are--- performed to the same location), the result is unspecified. It is--- not guaranteed that one of the duplicate writes will complete--- atomically - they may be interleaved. See `reduce_by_index`@term--- for a function that can handle this case deterministically.+-- in `is`. Notice that writing outside the index domain of the target+-- array has no effect. If `is` contains duplicates for valid indexes+-- into the target array (i.e., several writes are performed to the+-- same location), the result is unspecified. It is not guaranteed+-- that one of the duplicate writes will complete atomically - they+-- may be interleaved. See `reduce_by_index`@term for a function that+-- can handle this case deterministically. -- -- This is technically not a second-order operation, but it is defined -- here because it is closely related to the SOACs.
prelude/zip.fut view
@@ -19,7 +19,7 @@ -- | Construct an array of pairs from two arrays. let zip2 [n] 'a 'b (as: [n]a) (bs: [n]b): *[n](a,b) =- zip as bs :> [n](a,b)+ zip as bs :> *[n](a,b) -- | As `zip2`@term, but with one more array. let zip3 [n] 'a 'b 'c (as: [n]a) (bs: [n]b) (cs: [n]c): *[n](a,b,c) =
src/Futhark/CLI/Literate.hs view
@@ -27,6 +27,7 @@ import Data.Void import Data.Word (Word32, Word8) import Futhark.Data+import Futhark.Data.Reader import Futhark.Script import Futhark.Server import Futhark.Test@@ -463,6 +464,18 @@ void $ system "convert" [imgfile, "-type", "TrueColorAlpha", bmpfile] mempty loadBMP bmpfile +loadData :: FilePath -> ScriptM (Compound Value)+loadData datafile = do+ contents <- liftIO $ LBS.readFile datafile+ let maybe_vs = readValues contents+ case maybe_vs of+ Nothing ->+ throwError $ "Failed to read data file " <> T.pack datafile+ Just [v] ->+ pure $ ValueAtom v+ Just vs ->+ pure $ ValueTuple $ map ValueAtom vs+ literateBuiltin :: EvalBuiltin ScriptM literateBuiltin "loadimg" vs = case vs of@@ -472,8 +485,18 @@ loadImage path' _ -> throwError $- "$imgfile does not accept arguments of types: "+ "$loadimg does not accept arguments of types: " <> T.intercalate ", " (map (prettyText . fmap valueType) vs)+literateBuiltin "loaddata" vs =+ case vs of+ [ValueAtom v]+ | Just path <- getValue v -> do+ let path' = map (chr . fromIntegral) (path :: [Word8])+ loadData path'+ _ ->+ throwError $+ "$loaddata does not accept arguments of types: "+ <> T.intercalate ", " (map (prettyText . fmap valueType) vs) literateBuiltin f _ = throwError $ "Unknown builtin function $" <> prettyText f @@ -838,12 +861,12 @@ "v" ["verbose"] (NoArg $ Right $ \config -> config {scriptVerbose = scriptVerbose config + 1})- "Enable logging. Pass multiple times for more.",+ "Enable logging. Pass multiple times for more.", Option "o" ["output"] (ReqArg (\opt -> Right $ \config -> config {scriptOutput = Just opt}) "FILE")- "Enable logging. Pass multiple times for more.",+ "Override output file. Image directory is set to basename appended with -img/.", Option [] ["stop-on-error"]
src/Futhark/CLI/REPL.hs view
@@ -53,7 +53,7 @@ run [prog] _ = Just $ repl $ Just prog run _ _ = Nothing -data StopReason = EOF | Stop | Exit | Load FilePath+data StopReason = EOF | Stop | Exit | Load FilePath | Interrupt repl :: Maybe FilePath -> IO () repl maybe_prog = do@@ -66,11 +66,18 @@ putStrLn "" let toploop s = do- (stop, s') <- runStateT (runExceptT $ runFutharkiM $ forever readEvalPrint) s+ (stop, s') <-+ Haskeline.handleInterrupt (pure (Left Interrupt, s))+ . Haskeline.withInterrupt+ $ runStateT (runExceptT $ runFutharkiM $ forever readEvalPrint) s+ case stop of Left Stop -> finish s' Left EOF -> finish s' Left Exit -> finish s'+ Left Interrupt -> do+ liftIO $ T.putStrLn "Interrupted"+ toploop s' {futharkiCount = futharkiCount s' + 1} Left (Load file) -> do liftIO $ T.putStrLn $ "Loading " <> T.pack file maybe_new_state <-
src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs view
@@ -103,7 +103,8 @@ GC.earlyDecl [C.cedecl|struct tuning_params { $sdecls:size_decls };|] cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|],- [C.cedecl|struct $id:s { struct cuda_config cu_cfg;+ [C.cedecl|struct $id:s {int in_use;+ struct cuda_config cu_cfg; int profiling; typename int64_t tuning_params[$int:num_sizes]; int num_nvrtc_opts;@@ -122,6 +123,7 @@ if (cfg == NULL) { return NULL; }+ cfg->in_use = 0; cfg->profiling = 0; cfg->num_nvrtc_opts = 0;@@ -138,6 +140,7 @@ GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], [C.cedecl|void $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); free(cfg->nvrtc_opts); free(cfg); }|]@@ -324,6 +327,7 @@ ctx <- GC.publicDef "context" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s {+ struct $id:cfg* cfg; int detail_memory; int debugging; int profiling;@@ -357,10 +361,13 @@ GC.publicDef_ "context_new" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); if (ctx == NULL) { return NULL; }+ ctx->cfg = cfg;+ ctx->cfg->in_use = 1; ctx->debugging = ctx->detail_memory = cfg->cu_cfg.debugging; ctx->profiling = cfg->profiling; ctx->profiling_paused = 0;@@ -415,6 +422,7 @@ free_constants(ctx); cuda_cleanup(&ctx->cuda); free_lock(&ctx->lock);+ ctx->cfg->in_use = 0; free(ctx); }|] )
src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs view
@@ -100,10 +100,11 @@ GC.earlyDecl [C.cedecl|struct tuning_params { $sdecls:size_decls };|] cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|],- [C.cedecl|struct $id:s { struct opencl_config opencl;- typename int64_t tuning_params[$int:num_sizes];- int num_build_opts;- const char **build_opts;+ [C.cedecl|struct $id:s { int in_use;+ struct opencl_config opencl;+ typename int64_t tuning_params[$int:num_sizes];+ int num_build_opts;+ const char **build_opts; };|] ) @@ -119,6 +120,7 @@ return NULL; } + cfg->in_use = 0; cfg->num_build_opts = 0; cfg->build_opts = (const char**) malloc(sizeof(const char*)); cfg->build_opts[0] = NULL;@@ -133,6 +135,7 @@ GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], [C.cedecl|void $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); free(cfg->build_opts); free(cfg); }|]@@ -307,6 +310,7 @@ ctx <- GC.publicDef "context" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s {+ struct $id:cfg* cfg; int detail_memory; int debugging; int profiling;@@ -400,10 +404,13 @@ GC.publicDef_ "context_new" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); if (ctx == NULL) { return NULL; }+ ctx->cfg = cfg;+ ctx->cfg->in_use = 1; int required_types = 0; $stms:set_required_types@@ -418,10 +425,13 @@ GC.publicDef_ "context_new_with_command_queue" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg, typename cl_command_queue queue);|], [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg, typename cl_command_queue queue) {+ assert(!cfg->in_use); struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); if (ctx == NULL) { return NULL; }+ ctx->cfg = cfg;+ ctx->cfg->in_use = 1; int required_types = 0; $stms:set_required_types@@ -441,6 +451,7 @@ free_lock(&ctx->lock); $stms:(map releaseKernel (M.toList kernels)) teardown_opencl(&ctx->opencl);+ ctx->cfg->in_use = 0; free(ctx); }|] )
src/Futhark/CodeGen/Backends/MulticoreC.hs view
@@ -54,7 +54,8 @@ cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|],- [C.cedecl|struct $id:s { int debugging;+ [C.cedecl|struct $id:s { int in_use;+ int debugging; int profiling; int num_threads; };|]@@ -67,6 +68,7 @@ if (cfg == NULL) { return NULL; }+ cfg->in_use = 0; cfg->debugging = 0; cfg->profiling = 0; cfg->num_threads = 0;@@ -77,6 +79,7 @@ GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], [C.cedecl|void $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); free(cfg); }|] )@@ -115,6 +118,7 @@ ctx <- GC.publicDef "context" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s {+ struct $id:cfg* cfg; struct scheduler scheduler; int detail_memory; int debugging;@@ -137,10 +141,13 @@ GC.publicDef_ "context_new" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); if (ctx == NULL) { return NULL; }+ ctx->cfg = cfg;+ ctx->cfg->in_use = 1; // Initialize rand() fast_srand(time(0));@@ -184,6 +191,7 @@ free_constants(ctx); (void)scheduler_destroy(&ctx->scheduler); free_lock(&ctx->lock);+ ctx->cfg->in_use = 0; free(ctx); }|] )
src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs view
@@ -9,7 +9,7 @@ generateBoilerplate = do cfg <- GC.publicDef "context_config" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|],- [C.cedecl|struct $id:s { int debugging; };|]+ [C.cedecl|struct $id:s { int debugging; int in_use; };|] ) GC.publicDef_ "context_config_new" GC.InitDecl $ \s ->@@ -19,6 +19,7 @@ if (cfg == NULL) { return NULL; }+ cfg->in_use = 0; cfg->debugging = 0; return cfg; }|]@@ -27,6 +28,7 @@ GC.publicDef_ "context_config_free" GC.InitDecl $ \s -> ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|], [C.cedecl|void $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); free(cfg); }|] )@@ -58,6 +60,7 @@ ctx <- GC.publicDef "context" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:s;|], [C.cedecl|struct $id:s {+ struct $id:cfg* cfg; int detail_memory; int debugging; int profiling;@@ -73,10 +76,14 @@ GC.publicDef_ "context_new" GC.InitDecl $ \s -> ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|], [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {+ assert(!cfg->in_use); struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx)); if (ctx == NULL) { return NULL; }+ ctx->cfg = cfg;+ ctx->cfg->in_use = 1;+ ctx->detail_memory = cfg->debugging; ctx->debugging = cfg->debugging; ctx->profiling = cfg->debugging;@@ -96,6 +103,7 @@ $stms:free_fields free_constants(ctx); free_lock(&ctx->lock);+ ctx->cfg->in_use = 0; free(ctx); }|] )
src/Futhark/Internalise/Exps.hs view
@@ -1758,7 +1758,16 @@ assert "dim_ok_cert" dim_ok- "new shape has different number of elements than old shape"+ ( ErrorMsg+ [ "Cannot unflatten array of shape [",+ ErrorVal int64 old_dim,+ "] to array of shape [",+ ErrorVal int64 n',+ "][",+ ErrorVal int64 m',+ "]"+ ]+ ) loc certifying dim_ok_cert $ forM arrs $ \arr' -> do
src/Futhark/Internalise/Monomorphise.hs view
@@ -750,7 +750,11 @@ body' <- updateExpTypes (`M.lookup` substs') body body'' <- withRecordReplacements (mconcat rrs) $ transformExp body'- name' <- if null tparams && not entry then return name else newName name+ seen_before <- elem name . map (fst . fst) <$> getLifts+ name' <-+ if null tparams && not entry && not seen_before+ then pure name+ else newName name return ( name',
src/Language/Futhark/Interpreter.hs view
@@ -1879,10 +1879,19 @@ return $ toArray (ShapeDim (n * m) shape) $ concatMap (snd . fromArray) xs' def "unflatten" = Just $ fun3t $ \n m xs -> do- let (ShapeDim _ innershape, xs') = fromArray xs+ let (ShapeDim xs_size innershape, xs') = fromArray xs rowshape = ShapeDim (asInt64 m) innershape shape = ShapeDim (asInt64 n) rowshape- return $ toArray shape $ map (toArray rowshape) $ chunk (asInt m) xs'+ if asInt64 n * asInt64 m /= xs_size+ then+ bad mempty mempty $+ "Cannot unflatten array of shape [" <> pretty xs_size+ <> "] to array of shape ["+ <> pretty (asInt64 n)+ <> "]["+ <> pretty (asInt64 m)+ <> "]"+ else pure $ toArray shape $ map (toArray rowshape) $ chunk (asInt m) xs' def "acc" = Nothing def s | nameFromString s `M.member` namesToPrimTypes = Nothing def s = error $ "Missing intrinsic: " ++ s
src/Language/Futhark/Prop.hs view
@@ -277,7 +277,7 @@ diet (Array _ Nonunique _ _) = Observe diet (Scalar (TypeVar _ Unique _ _)) = Consume diet (Scalar (TypeVar _ Nonunique _ _)) = Observe-diet (Scalar Sum {}) = Observe+diet (Scalar (Sum cs)) = SumDiet $ M.map (map diet) cs -- | Convert any type to one that has rank information, no alias -- information, and no embedded names.
src/Language/Futhark/Syntax.hs view
@@ -565,6 +565,8 @@ data Diet = -- | Consumes these fields in the record. RecordDiet (M.Map Name Diet)+ | -- | Consume these parts of the constructors.+ SumDiet (M.Map Name [Diet]) | -- | A function that consumes its argument(s) like this. -- The final 'Diet' should always be 'Observe', as there -- is no way for a function to consume its return value.
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -636,7 +636,9 @@ (rettype', rettype_st) <- case rettype_checked of- Just (te, st, ext) ->+ Just (te, st, ext) -> do+ let st_structural = toStructural st+ checkReturnAlias loc st_structural params'' body_t pure (Just te, RetType ext st) Nothing -> do ret <-@@ -944,6 +946,11 @@ checkIfConsumable loc $ S.map AliasBound $ allConsumed occurs occur occurs + -- Unification ignores uniqueness in higher-order arguments, so+ -- we check for that here.+ unless (toStructural argtype' `subtypeOf` toStructural tp1') $+ typeError loc mempty "Uniqueness does not match."+ (argext, parsubst) <- case pname of Named pname'@@ -1030,12 +1037,16 @@ maskAliases t Observe = t maskAliases (Scalar (Record ets)) (RecordDiet ds) = Scalar $ Record $ M.intersectionWith maskAliases ets ds+maskAliases (Scalar (Sum ets)) (SumDiet ds) =+ Scalar $ Sum $ M.intersectionWith (zipWith maskAliases) ets ds maskAliases t FuncDiet {} = t maskAliases _ _ = error "Invalid arguments passed to maskAliases." consumeArg :: SrcLoc -> PatType -> Diet -> TermTypeM [Occurrence] consumeArg loc (Scalar (Record ets)) (RecordDiet ds) = concat . M.elems <$> traverse (uncurry $ consumeArg loc) (M.intersectionWith (,) ets ds)+consumeArg loc (Scalar (Sum ets)) (SumDiet ds) =+ concat <$> traverse (uncurry $ consumeArg loc) (concat $ M.elems $ M.intersectionWith zip ets ds) consumeArg loc (Array _ Nonunique _ _) Consume = typeError loc mempty . withIndexLink "consuming-parameter" $ "Consuming parameter passed non-unique argument."@@ -1340,6 +1351,38 @@ where hidden = hiddenParamNames params +checkReturnAlias :: SrcLoc -> TypeBase () () -> [Pat] -> PatType -> TermTypeM ()+checkReturnAlias loc rettp params =+ foldM_ (checkReturnAlias' params) S.empty . returnAliasing rettp+ where+ checkReturnAlias' params' seen (Unique, names)+ | any (`S.member` S.map snd seen) $ S.toList names =+ uniqueReturnAliased loc+ | otherwise = do+ notAliasingParam params' names+ pure $ seen `S.union` tag Unique names+ checkReturnAlias' _ seen (Nonunique, names)+ | any (`S.member` seen) $ S.toList $ tag Unique names =+ uniqueReturnAliased loc+ | otherwise = pure $ seen `S.union` tag Nonunique names++ notAliasingParam params' names =+ forM_ params' $ \p ->+ let consumedNonunique p' =+ not (unique $ unInfo $ identType p') && (identName p' `S.member` names)+ in case find consumedNonunique $ S.toList $ patIdents p of+ Just p' ->+ returnAliased (baseName $ identName p') loc+ Nothing ->+ pure ()++ tag u = S.map (u,)++ returnAliasing (Scalar (Record ets1)) (Scalar (Record ets2)) =+ concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2+ returnAliasing expected got =+ [(uniqueness expected, S.map aliasVar $ aliases got)]+ checkBinding :: ( Name, Maybe UncheckedTypeExp,@@ -1357,8 +1400,7 @@ ) checkBinding (fname, maybe_retdecl, tparams, params, body, loc) = noUnique . incLevel . bindingParams tparams params $ \tparams' params' -> do- maybe_retdecl' <- forM maybe_retdecl $ \retdecl ->- checkTypeExpNonrigid retdecl+ maybe_retdecl' <- traverse checkTypeExpNonrigid maybe_retdecl body' <- checkFunBody@@ -1373,7 +1415,7 @@ (maybe_retdecl'', rettype) <- case maybe_retdecl' of Just (retdecl', ret, _) -> do let rettype_structural = toStructural ret- checkReturnAlias rettype_structural params'' body_t+ checkReturnAlias loc rettype_structural params'' body_t when (null params) $ nothingMustBeUnique loc rettype_structural @@ -1395,37 +1437,7 @@ checkGlobalAliases params'' body_t loc pure (tparams'', params''', maybe_retdecl'', rettype'', body')- where- checkReturnAlias rettp params' =- foldM_ (checkReturnAlias' params') S.empty . returnAliasing rettp- checkReturnAlias' params' seen (Unique, names)- | any (`S.member` S.map snd seen) $ S.toList names =- uniqueReturnAliased fname loc- | otherwise = do- notAliasingParam params' names- pure $ seen `S.union` tag Unique names- checkReturnAlias' _ seen (Nonunique, names)- | any (`S.member` seen) $ S.toList $ tag Unique names =- uniqueReturnAliased fname loc- | otherwise = pure $ seen `S.union` tag Nonunique names - notAliasingParam params' names =- forM_ params' $ \p ->- let consumedNonunique p' =- not (unique $ unInfo $ identType p') && (identName p' `S.member` names)- in case find consumedNonunique $ S.toList $ patIdents p of- Just p' ->- returnAliased fname (baseName $ identName p') loc- Nothing ->- pure ()-- tag u = S.map (u,)-- returnAliasing (Scalar (Record ets1)) (Scalar (Record ets2)) =- concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2- returnAliasing expected got =- [(uniqueness expected, S.map aliasVar $ aliases got)]- -- | Extract all the shape names that occur in positive position -- (roughly, left side of an arrow) in a given type. typeDimNamesPos :: TypeBase (DimDecl VName) als -> S.Set VName@@ -1715,7 +1727,7 @@ -- We also have to make sure that uniqueness matches. This is done -- explicitly, because uniqueness is ignored by unification. rettype' <- normTypeFully rettype- body_t'' <- normTypeFully rettype -- Substs may have changed.+ body_t'' <- normTypeFully body_t' -- Substs may have changed. unless (toStructural body_t'' `subtypeOf` toStructural rettype') $ typeError (srclocOf body) mempty $ "Body type" </> indent 2 (ppr body_t'')
src/Language/Futhark/TypeChecker/Terms/Monad.hs view
@@ -248,19 +248,16 @@ </> indent 2 (ppr vale) </> "Hint: use" <+> pquote "copy" <+> "to remove aliases from the value." -returnAliased :: Name -> Name -> SrcLoc -> TermTypeM ()-returnAliased fname name loc =+returnAliased :: Name -> SrcLoc -> TermTypeM ()+returnAliased name loc = typeError loc mempty . withIndexLink "return-aliased" $- "Unique-typed return value of" <+> pquote (pprName fname)- <+> "is aliased to"+ "Unique-typed return value is aliased to" <+> pquote (pprName name) <> ", which is not consumable." -uniqueReturnAliased :: Name -> SrcLoc -> TermTypeM a-uniqueReturnAliased fname loc =+uniqueReturnAliased :: SrcLoc -> TermTypeM a+uniqueReturnAliased loc = typeError loc mempty . withIndexLink "unique-return-aliased" $- "A unique-typed component of the return value of"- <+> pquote (pprName fname)- <+> "is aliased to some other component."+ "A unique-typed component of the return value is aliased to some other component." unexpectedType :: MonadTypeChecker m => SrcLoc -> StructType -> [StructType] -> m a unexpectedType loc _ [] =