diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -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`` .......... diff --git a/docs/man/futhark-literate.rst b/docs/man/futhark-literate.rst --- a/docs/man/futhark-literate.rst +++ b/docs/man/futhark-literate.rst @@ -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 ====== 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.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 diff --git a/prelude/array.fut b/prelude/array.fut --- a/prelude/array.fut +++ b/prelude/array.fut @@ -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. diff --git a/prelude/soacs.fut b/prelude/soacs.fut --- a/prelude/soacs.fut +++ b/prelude/soacs.fut @@ -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. diff --git a/prelude/zip.fut b/prelude/zip.fut --- a/prelude/zip.fut +++ b/prelude/zip.fut @@ -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) = diff --git a/src/Futhark/CLI/Literate.hs b/src/Futhark/CLI/Literate.hs --- a/src/Futhark/CLI/Literate.hs +++ b/src/Futhark/CLI/Literate.hs @@ -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"] diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -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 <- diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -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); }|] ) diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -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); }|] ) diff --git a/src/Futhark/CodeGen/Backends/MulticoreC.hs b/src/Futhark/CodeGen/Backends/MulticoreC.hs --- a/src/Futhark/CodeGen/Backends/MulticoreC.hs +++ b/src/Futhark/CodeGen/Backends/MulticoreC.hs @@ -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); }|] ) diff --git a/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs b/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/SequentialC/Boilerplate.hs @@ -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); }|] ) diff --git a/src/Futhark/Internalise/Exps.hs b/src/Futhark/Internalise/Exps.hs --- a/src/Futhark/Internalise/Exps.hs +++ b/src/Futhark/Internalise/Exps.hs @@ -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 diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -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', diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -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 diff --git a/src/Language/Futhark/Prop.hs b/src/Language/Futhark/Prop.hs --- a/src/Language/Futhark/Prop.hs +++ b/src/Language/Futhark/Prop.hs @@ -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. diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -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. diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -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'') diff --git a/src/Language/Futhark/TypeChecker/Terms/Monad.hs b/src/Language/Futhark/TypeChecker/Terms/Monad.hs --- a/src/Language/Futhark/TypeChecker/Terms/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Terms/Monad.hs @@ -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 _ [] =