diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -1029,7 +1029,7 @@ *Size-dependent types* are supported, as the names of parameters can be used in the return type of a function:: - let replicate 't (n: i32) (x: t): [n]t = ... + let replicate 't (n: i64) (x: t): [n]t = ... An application ``replicate 10 0`` will have type ``[10]i32``. diff --git a/docs/man/futhark-repl.rst b/docs/man/futhark-repl.rst --- a/docs/man/futhark-repl.rst +++ b/docs/man/futhark-repl.rst @@ -24,7 +24,7 @@ command to see a list of commands. All commands are prefixed with a colon. -``futhark-repl`` uses the Futhark interpreter, which grants access to +``futhark repl`` uses the Futhark interpreter, which grants access to certain special functions. See :ref:`futhark-run(1)` for a description. OPTIONS diff --git a/docs/man/futhark-run.rst b/docs/man/futhark-run.rst --- a/docs/man/futhark-run.rst +++ b/docs/man/futhark-run.rst @@ -18,9 +18,9 @@ arguments read from standard input, and write the results on standard output. -``futhark-run`` is very slow, and in practice only useful for testing, +``futhark run`` is very slow, and in practice only useful for testing, teaching, and experimenting with the language. Certain special -debugging functions are available in ``futhark-run``: +debugging functions are available in ``futhark run``: ``trace 'a : a -> a`` Semantically identity, but prints the value on standard output. diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: futhark -version: 0.18.4 +version: 0.18.5 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/src/Futhark/CLI/Bench.hs b/src/Futhark/CLI/Bench.hs --- a/src/Futhark/CLI/Bench.hs +++ b/src/Futhark/CLI/Bench.hs @@ -467,7 +467,9 @@ -- | Run @futhark bench@. main :: String -> [String] -> IO () main = mainWithOptions initialBenchOptions commandLineOptions "options... programs..." $ \progs config -> - Just $ runBenchmarks config progs + case progs of + [] -> Nothing + _ -> Just $ runBenchmarks config progs --- The following extracted from hstats package by Marshall Beddoe: --- https://hackage.haskell.org/package/hstats-0.3 diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -719,4 +719,6 @@ -- | Run @futhark test@. main :: String -> [String] -> IO () main = mainWithOptions defaultConfig commandLineOptions "options... programs..." $ \progs config -> - Just $ runTests config progs + case progs of + [] -> Nothing + _ -> Just $ runTests config progs diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -1170,7 +1170,7 @@ if (!($exp:(allTrue entry_point_input_checks))) { ret = 1; if (!ctx->error) { - ctx->error = msgprintf("Error: entry point arguments have invalid sizes."); + ctx->error = msgprintf("Error: entry point arguments have invalid sizes.\n"); } } else { ret = $id:(funName fname)(ctx, $args:out_args, $args:in_args); diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs --- a/src/Futhark/IR/SegOp.hs +++ b/src/Futhark/IR/SegOp.hs @@ -56,7 +56,8 @@ import Control.Monad.Writer hiding (mapM_) import Data.Bifunctor (first) import Data.List - ( foldl', + ( elemIndex, + foldl', groupBy, intersperse, isPrefixOf, @@ -1332,6 +1333,24 @@ ) topDownSegOp _ _ _ _ = Skip +-- A convenient way of operating on the type and body of a SegOp, +-- without worrying about exactly what kind it is. +segOpGuts :: + SegOp (SegOpLevel lore) lore -> + ( [Type], + KernelBody lore, + Int, + [Type] -> KernelBody lore -> SegOp (SegOpLevel lore) lore + ) +segOpGuts (SegMap lvl space kts body) = + (kts, body, 0, SegMap lvl space) +segOpGuts (SegScan lvl space ops kts body) = + (kts, body, segBinOpResults ops, SegScan lvl space ops) +segOpGuts (SegRed lvl space ops kts body) = + (kts, body, segBinOpResults ops, SegRed lvl space ops) +segOpGuts (SegHist lvl space ops kts body) = + (kts, body, sum $ map (length . histDest) ops, SegHist lvl space ops) + bottomUpSegOp :: (HasSegOp lore, BinderOps lore) => (ST.SymbolTable lore, UT.UsageTable) -> @@ -1341,10 +1360,13 @@ Rule lore -- Some SegOp results can be moved outside the SegOp, which can -- simplify further analysis. -bottomUpSegOp (vtable, used) (Pattern [] kpes) dec (SegMap lvl space kts (KernelBody _ kstms kres)) = Simplify $ do +bottomUpSegOp (vtable, used) (Pattern [] kpes) dec segop = Simplify $ do -- Iterate through the bindings. For each, we check whether it is -- in kres and can be moved outside. If so, we remove it from kres - -- and kpes and make it a binding outside. + -- and kpes and make it a binding outside. We have to be careful + -- not to remove anything that is passed on to a scan/map/histogram + -- operation. Fortunately, these are always first in the result + -- list. (kpes', kts', kres', kstms') <- localScope (scopeOfSegSpace space) $ foldM distribute (kpes, kts, kres, mempty) kstms @@ -1357,13 +1379,12 @@ localScope (scopeOfSegSpace space) $ mkKernelBodyM kstms' kres' - addStm $ - Let (Pattern [] kpes') dec $ - Op $ - segOp $ - SegMap lvl space kts' kbody + addStm $ Let (Pattern [] kpes') dec $ Op $ segOp $ mk_segop kts' kbody where + (kts, KernelBody _ kstms kres, num_nonmap_results, mk_segop) = + segOpGuts segop free_in_kstms = foldMap freeIn kstms + space = segSpace segop sliceWithGtidsFixed stm | Let _ _ (BasicOp (Index arr slice)) <- stm, @@ -1415,7 +1436,9 @@ isResult kpes' kts' kres' pe = case partition matches $ zip3 kpes' kts' kres' of ([(kpe, _, _)], kpes_and_kres) - | (kpes'', kts'', kres'') <- unzip3 kpes_and_kres -> + | Just i <- elemIndex kpe kpes, + i >= num_nonmap_results, + (kpes'', kts'', kres'') <- unzip3 kpes_and_kres -> Just (kpe, kpes'', kts'', kres'') _ -> Nothing where diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs --- a/src/Futhark/Internalise/TypesValues.hs +++ b/src/Futhark/Internalise/TypesValues.hs @@ -150,12 +150,12 @@ where onConstructor (ts, mapping) ((c, c_ts), i) = let (_, js, new_ts) = - foldl' f (zip ts [0 ..], mempty, mempty) c_ts + foldl' f (zip (map fromDecl ts) [0 ..], mempty, mempty) c_ts in (ts ++ new_ts, M.insert c (i, js) mapping) where f (ts', js, new_ts) t - | Just (_, j) <- find ((== t) . fst) ts' = - ( delete (t, j) ts', + | Just (_, j) <- find ((== fromDecl t) . fst) ts' = + ( delete (fromDecl t, j) ts', js ++ [j], new_ts ) diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -312,7 +312,7 @@ used <> freeIn recomputed_variant_prestms prelude_arrs <- inScopeOf precomputed_variant_prestms $ - doPrelude tiling precomputed_variant_prestms live_set + doPrelude tiling privstms precomputed_variant_prestms live_set let prelude_privstms = PrivStms recomputed_variant_prestms $ @@ -363,7 +363,7 @@ prelude_arrs <- inScopeOf precomputed_variant_prestms $ - doPrelude tiling precomputed_variant_prestms live_set + doPrelude tiling privstms precomputed_variant_prestms live_set mergeparams' <- forM mergeparams $ \(Param pname pt) -> Param <$> newVName (baseString pname ++ "_group") <*> pure (tileDim pt) @@ -413,17 +413,18 @@ filter (`notElem` unSegSpace (tilingSpace tiling)) $ unSegSpace initial_space -doPrelude :: Tiling -> Stms Kernels -> [VName] -> Binder Kernels [VName] -doPrelude tiling prestms prestms_live = +doPrelude :: Tiling -> PrivStms -> Stms Kernels -> [VName] -> Binder Kernels [VName] +doPrelude tiling privstms prestms prestms_live = -- Create a SegMap that takes care of the prelude for every thread. tilingSegMap tiling "prelude" (scalarLevel tiling) ResultPrivate $ - \in_bounds _slice -> do + \in_bounds slice -> do ts <- mapM lookupType prestms_live fmap (map Var) $ letTupExp "pre" =<< eIf (toExp in_bounds) ( do + addPrivStms slice privstms addStms prestms resultBodyM $ map Var prestms_live ) 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 @@ -655,7 +655,7 @@ else bodyInterest (lambdaBody lam') | Op Scatter {} <- stmExp stm = 0 -- Basically a map. - | DoLoop _ _ _ body <- stmExp stm = + | DoLoop _ _ ForLoop {} body <- stmExp stm = bodyInterest body * 10 | Op (Screma _ form@(ScremaForm _ _ lam') _) <- stmExp stm = 1 + bodyInterest (lambdaBody lam') 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 @@ -262,17 +262,19 @@ _ == _ = False instance Pretty Value where - ppr (ValuePrim v) = ppr v - ppr (ValueArray _ a) = + ppr = pprPrec 0 + pprPrec _ (ValuePrim v) = ppr v + pprPrec _ (ValueArray _ a) = let elements = elems a -- [Value] (x : _) = elements separator = case x of ValueArray _ _ -> comma <> line _ -> comma <> space in brackets $ cat $ punctuate separator (map ppr elements) - ppr (ValueRecord m) = prettyRecord m - ppr ValueFun {} = text "#" - ppr (ValueSum _ n vs) = text "#" <> sep (ppr n : map ppr vs) + pprPrec _ (ValueRecord m) = prettyRecord m + pprPrec _ ValueFun {} = text "#" + pprPrec p (ValueSum _ n vs) = + parensIf (p > 0) $ text "#" <> sep (ppr n : map (pprPrec 1) vs) valueShape :: Value -> ValueShape valueShape (ValueArray shape _) = shape @@ -1698,9 +1700,9 @@ interpretFunction ctx fname vs = do ft <- case lookupVar (qualName fname) $ ctxEnv ctx of Just (TermValue (Just (T.BoundV _ t)) _) -> - Right $ updateType (map valueType vs) t + updateType (map valueType vs) t Just (TermPoly (Just (T.BoundV _ t)) _) -> - Right $ updateType (map valueType vs) t + updateType (map valueType vs) t _ -> Left $ "Unknown function `" <> prettyName fname <> "`." @@ -1715,9 +1717,26 @@ f <- evalTermVar (ctxEnv ctx) (qualName fname) ft foldM (apply noLoc mempty) f vs' where - updateType (vt : vts) (Scalar (Arrow als u _ rt)) = - Scalar $ Arrow als u (valueStructType vt) $ updateType vts rt - updateType _ t = t + updateType (vt : vts) (Scalar (Arrow als u pt rt)) = do + checkInput vt pt + Scalar . Arrow als u (valueStructType vt) <$> updateType vts rt + updateType _ t = + Right t + + -- FIXME: we don't check array sizes. + checkInput :: ValueType -> StructType -> Either String () + checkInput (Scalar (Prim vt)) (Scalar (Prim pt)) + | vt /= pt = badPrim vt pt + checkInput (Array _ _ (Prim vt) _) (Array _ _ (Prim pt) _) + | vt /= pt = badPrim vt pt + checkInput _ _ = + Right () + + badPrim vt pt = + Left . pretty $ + "Invalid argument type." + "Expected:" <+> align (ppr pt) + "Got: " <+> align (ppr vt) convertValue (F.PrimValue p) = Just $ ValuePrim p convertValue (F.ArrayValue arr t) = mkArray t =<< mapM convertValue (elems arr) diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -147,7 +147,7 @@ oneLine (mconcat $ punctuate (text " | ") cs') <|> align (mconcat $ punctuate (text " |" <> line) cs') where - ppConstr (name, fs) = sep $ (text "#" <> ppr name) : map (pprPrec 1) fs + ppConstr (name, fs) = sep $ (text "#" <> ppr name) : map (pprPrec 2) fs cs' = map ppConstr $ M.toList cs instance Pretty (ShapeDecl dim) => Pretty (TypeBase dim as) where diff --git a/src/Language/Futhark/TypeChecker/Unify.hs b/src/Language/Futhark/TypeChecker/Unify.hs --- a/src/Language/Futhark/TypeChecker/Unify.hs +++ b/src/Language/Futhark/TypeChecker/Unify.hs @@ -1115,7 +1115,7 @@ indent 2 (ppr t2) "do not match." --- | Construct a the name of a new type variable given a base +-- | Construct the name of a new type variable given a base -- description and a tag number (note that this is distinct from -- actually constructing a VName; the tag here is intended for human -- consumption but the machine does not care).